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POLICY: PASCAL NEWS (15-Sep-80) 

* Pascal News is the official but informal publication of the User's Group. 

* Pascal News contains all we (the editors) know about Pascal; we use it as 
the vehicle to answer all inquiries because our physical energy and 
resources for answering individual requests are finite. As PUG grows, we 
unfortunately succumb to the reality of: 

1. Having to insist that people who need to know "about Pascal" join PUG 
and read Pascal News - that is why we spend time to produce it! 

2. Refusing to return phone calls or answer letters full of questions - we 
will pass the questions on to the readership of Pascal News . Please 
understand what the collective effect of individual inquiries has at the 
"concentrators" (our phones and mailboxes). We are trying honestly to say: 
"We cannot promise more that we can do." 

* Pascal News is produced 3 or 4 times during a year; usually in March, 3une, 
September, and December. 

* ALL THE NEWS THAT'S FIT, WE PRINT. Please send material (brevity is a 
virtue) for Pascal News single-spaced and camera-ready (use dark ribbon and 
18.5 cm lines! ) 

^| * Remember: ALL LETTERS TO US WILL BE PRINTED UNLESS THEY CONTAIN A REQUEST 
fT TO THE CONTRARY. 

■■■ * Pascal News is divided into flexible sections: 

ft POLICY - explains the way we do things (ALL-PURPOSE COUPON, etc.) 

EDITOR'S CONTRIBUTION - passes along the opinion and point of view of the 
editor together with changes in the mechanics of PUG operation, etc. 

HERE AND THERE WITH PASCAL - presents news from people, conference 
announcements and reports, new books and articles (including reviews), 
notices of Pascal in the news, history, membership rosters, etc. 

APPLICATIONS - presents and documents source programs written in Pascal 
for various algorithms, and software tools for a Pascal environment; news 
of significant applications programs. Also critiques regarding 
program/ algorithm certification, performance, standards conformance, 
style, output convenience, and general design. 

ARTICLES - contains formal, submitted contributions (such as Pascal 
philosophy, use of Pascal as a teaching tool, use of Pascal at different 
computer installations, how to promote Pascal, etc.). 

OPEN FORUM FOR MEMBERS - contains short, informal correspondence among 
members which is of interest to the readership of Pascal News . 

IMPLEMENTATION NOTES - reports news of Pascal implementations: contacts 
for maintainers, implementors, distributors, and documentors of various 
implementations as well as where to send bug reports. Qualitative and 
quantitative descriptions and comparisons of various implementations are 
publicized. Sections contain information about Portable Pascals, Pascal 
Variants, Feature-Implementation Notes, and Machine-Dependent 
Implementations . 






ALL-PURPOSE COUPON (1'5-Dec-81) 



Pascal Usersj Group 
P.O. Box 4406 
Allentown, Pa. 18104-4406 USA 

**Note** 

We will not accept purchase orders. 

Make checks payable to: "Pascal Users Group" , drawn on a U.S. bank in 

U.S. dollars. 

Note the discounts below, for multi-year subscription and renewal. 

The U. S. Postal Service does not forward Pascal News. 



Enter me as a new member for: 
Renew my subscription for: 

Send Back Issue(s) 



USA 
[ ] 1 year $10. 
[ ] 2 years $18. 
[ ] 3 years $25. 



UK Europe Aust. 

#6. DM20. A$8. 

#10. DM45. A$15. 

#15. DM50. A$20. 



My new address/phone is listed below 

Enclosed please find a contribution, idea, article or opinion which is 
submitted for publication in the Pascal News. 

Comments: 
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COMPUTER , i 
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DATE 



JOINING PASCAL USERS GROUP? 

- Membership is open to anyone: Particularly the Pascal user, teacher , 
maintainer, implementor, distributor, or just plain fan. 

- Please enclose the proper prepayment (check payable to "Pascal User's 
Group"); we will not bill you. 

•«- Please do not send us purchase orders; we cannot endure the paper work! 

- When you join PUG any time within a year: January 1 to December 31 , you will 
receive all issues of Pascal News for that year. 

- We produce Pascal News as a means toward the end of promoting Pascal and 
communicating news of events surrounding Pascal to persons interested in 
Pascal. We are simply interested in the news ourselves and prefer to share 
it through Pascal News . We desire to minimize paperwork, because we have 
other work to do. 

- American Region (North and South America) Join through PUG(USA). 

- European Region (Europe, North Africa, Western Asia): Join through PUG(EUR) 
Pascal Users Group, c/o Grado Computer Systems & Software, 
Weissenburgerstrasse 25, D-8000, Munchen 80, Germany^ 

~ United Kingdom Region : join through PUG (UK) : Pascal Users Group, c/o 
Shetlandtel, Walls, Shetland, ZE2 9PF, United Kingdom. 

- Australasian Region (Australia, East Asia - incl. India & Japan): PUG(AUS). 
Pascal Users Group, c/o Arthur Sale, Department of Information Science, 
University of Tasmania, Box 252C GPO, Hobart, Tasmania 7001, Australia . 
International telephone: 61-02-202374 



RENEWING? 

- Please renew early (before November) and please write us a line or two to 
tell us what you are doing with Pascal, and tell us what you think of PUG and 
Pascal News . Renewing for more than one year saves us time. 

ORDERING BACK ISSUES OR EXTRA ISSUES? 

- Our unusual policy of automatically sending all issues of Pascal News to 
anyone who joins within a year means that we eliminate many requests for 
backissues ahead of time, and we don't have to reprint important information 
in every issue — especially about Pascal implementations! 

- Issues 1 .. 8 (January, 1974 - May 1977) are out of print . 

- Issues 9 .. 12, 13 .. 16, & 17 .. 20 are available from PUG (USA) all for 
$15.00 a set, and from PUG(AUS) all for $A15.00 a set. 

- Extra single copies of new issues (current academic year) are: $5.00 each - 
PUG(USA)* and $A5.00 each - PUG(AUS). 

SENDING MATERIAL FOR PUBLICATION? 

- Your experiences with Pascal (teaching and otherwise), ideas, letters, 
opinions, notices, news, articles, conference announcements, reports, 
implementation information, applications, etc. are welcome. Please send 
material single-spaced and in camera-ready (use a dark ribbon and lines 18.5 
cm. wide) form. 

- All letters will be printed unless they contain a request to the contrary. 
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ONE PURPOSE COUPON r POLICY 



APPLICATION FOR LICENSE TO USE VALIDATION SUITE FOR PASCAL 

Name and address of reqestor : 

(Company name if requestor is a company) : 



Phone Number: 

Name and address to which information should 
be addressed ( write ' ' as above ' ' if the same ) 



Signature of requestor: 
Date: 



In making this application, which should be signed by a responsible person in the case of a company, the re- 
questor agrees that: 

a ) The Validation Suite is recognized as being the copyrighted, proprietary property 
of R. A. Freak and A. H. J. Sale, and 

b) The requestor will not distribute or otherwise make available machine-readable 
copies 6i the Validation Suite, modified or unmodified, to any third party 
without written permission of the copyright holders. 

In return, the copyright holders grant full permission to use the programs and documentation contained in the 
Validation Suite for the purpose of compiler validation, acceptance tests, benchmarking, preparation of com- 
parative reports and similar purposes, and to make available the listings of the results of compilation and ex- 
ecution of the programs to third parties in the course of the above activities. In such documents, reference 
shall be made to the original copyright notice and its source. 

Distribution Charge: $50.00 

Make checks payable to ANPA/RI in US dollars drawn on a US bank. 

Remittance must accompany application. 

Source Code Delivery Medium Specification; 

( ) 800 bpi, 9-track, NRZI, odd parity, 600' magnetic tape 
( ) 1600 bpi, 9-track, PE, odd parity, 600' magnetic tape 

( ) ANSI-STANDARD 

a) Select Character Code Set: 

( ) ASCII ( ) EBCDIC 

b) Each logical record is an 80 character card image. Select block size in logical records per block. 

■ (',) 40 ( ) 20 ( ) 10 

( ) Special DEC System Alternates: 

( ) RSX-IAS PIP Format (requires ANSI MAGtape RSX SYSGEN) 
( ) DOS-RSTS FLX Format 

Office Use Only 

Signed ___ 

Date 



Mail Request to: 

ANPA/RI 

P.O. Box 598 

Easton, Pa. 18042 

USA 

Attn: R. J. Cichelli 



Richard J. Cichelli 
On behalf of A.H.J. Sale and R.A.Freak 



Editor's Contribution 



GOOFED AGAIN 



Yes as all /ou loyal Pen s vl ua'n i ans have notiood in the? last 
issue of PN we manased to mess up the sj.p cooe of Allontdwn PA? 
and of course the USPS has come down on us Hie a ton of bricks! 
Please note that the zip is 18014' nd-t 18.170. It has been 
corrected in the new APC 



THE NEW A PC 

SpeaKina of the new APC we have simplified it some -more .*• anti 
added current prices for the UK and Furope* and have modi f red the 
reverse side of the coupon to reflect the new fnreisn editors- 
and their current addresses* 



THE LATEST . EUROPEAN SOLUTION 

Speakina of the Furopean editors? we have two new ones! One for 
the UK t and one for the Continent. Ntcfe Hughes will, be handling 
all business for Britain? and Hellmut Weber will be in charse of 
the European Resion. Please see the APC for their addresses. 



ON CALLING 



Please restrict yourself to ■■written correspondence when deal ins 
with PUG* This is strictly 3 scholarly function. None of the 
edi tors < incj udins m v 'se I f ) ^et ? paid. AH, hatye a real Job that 
pays their b-illsr and they owe their off ire hours to their 
employer* All PUG work is donated on their own time. So please 
write to the appropriate regional editor, ft leaves a docufrtentar" 
trail that can be followed and handled as fast as we can. Honestf 



COMBINED ISSUE 



This is of course a combined issue. We mra doins this to catch up 
and to beat the postal 'system' and their his*h rates. IF this 
upsets anyone we are sorry. We ar& do lira our best. 



ON BEIN G THE EDITOR 

Anyone who is interested in beins the new editor of PN should 
write to me at the main address CAPO. 



STANDARDS 



Good news from the standard front! 
international committee. More next 
Standards Editor. 



?f$5. 1 u-mm appro ve# py the 
issue from Jim Miner the 



THIS ISSUE 



The hiahliaftt of ths issue is th 
issue at least!) of Andrew Tanen 
it is really areat. Tell us what 
There section Greaa Marshall has 
issues (15 . . 19) implementation 
to the EMI com#>ilerr the Applica 
improved version of the subrouti 
tree printina routine/ and a set 
expand text usins Huffman codes, 
articles section has some fine c 
have asked (on the phone ... see 
CP/m compilers stacK up. Now we 
is an article of the experiences 
Pascal. From a aeoaraphy teacher 
probina article by Jonathan Vavn 
Pascal and some proposals for th 



e lona awaited (from last 

baum's EMI compiler. I think 
you think! In the Here and 
summarized the past few 
notes. Thanx. In addition 

tions section includes an 

ne "options"* as well as a 
of routines to compress and 
Good work! And finally the 

ontributions. Many people 
above) about how the various 

have an answer. Also there 
of a novice teachina 
no less! And finally a 

er concernina problems with 

eir solution. 



Hope you like it, 
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Here and There With Pascal 

summary of Implementations 



ALL 

BESM-6 

Burroughs B5700 

Burroughs B6700/B7700 (MCP) 

CDC 6000 

CDC 6000 

Cyber 70 and 170 

DEC PDP-11 

DEC PDP-11 

DEC PDP-11 

DEC PDP-11 

DEC PDP-11 (RSTS) 

DEC PDP-11 (RSX-11M/IAS) 

DEC PDP-11 (RSX-11M/RT-11) 

DEC PDP-11 (Unix) 

DEC PDP-11 (Unix) 

DEC PDP-11 (Unix) 

DEC PDP-15 

DEC VAX 

DEC VAX (Unix) 

DG Eclipse 

DG Eclipse (AOS 

DG Eclipse (AOS) 

DG Eclipse (RDOS) 

DG Nova (AOS 

Digieo Micro 16E 

Facom 230-45S 

General Electric GEC4082 

Golem B (GOBOS) 

HP 1000 

Honeywell 6000 (GCOS III) 

Honeywell Level 6 

IBM 3033 

IBM 360/370 

IBM 360/370 

IBM 370 

IBM 370 

IBM 370 

IBM 370 

IBM 370/303x/43xx 

IBM Series 1 

IBM Series 1 

ICL 1900 

Intel 8080/8085 

Intel 8080/8085 

Intel 8080/8085 

Intel 8080/8085 

Intel 8080/8085 

Intel 8080/8085 (CP/M) 

Intel 8080/8085 (TRS-80) 

Intel 8080/8085 (Northstar) 

Intel 8086 

Intel 8086 

MOS Tech 6502 (Apple) 

Modcomp II and IV 



#15:101 

#15:107 

#15:107 

#19:113 

#19:115 

#15:108 

#15:108 

#19:115 

#15:111 

#15:112 

#15:124 

#15:100 

#17:86 

#15:101 

#15:111 

#15:100 

#15:103 

#15:124 

#17:89 

#19:115 

#17:106 

#15:110 

#15:109 

#15:108 

#15:110 

#15:113 

#15:112 

#15:113 

#17:104 

#19:116 

#15:113 

#15:113 

#19:120 

#15:114 

#15:115 

#17:104 

#19:117 

#15:124 

#17:102 

#19:117 

#19:116 

#15:114 

#15:116 

#15:119 

#15:118 

#15:119 

#17:102 

#15:117 

#17:105 

#15:100 

#15:100 

#15:119 

#15:103 

#15:107 

#15:120 



Pascal I (Derived from Pascal S) 



UCSD Pascal 

UCSD Pascal 

Pascal S 

Concurrent Pascal 

Pascal E 
Modula 



RDOS, DOS) 



RDOS, DOS) 



Motorola 6800 


#15:120 


Motorola 6800 


#19:120 


Motorola 6800 


#19:121 


Motorola 6800 


#17:102 


Motorola 6800 (Flex) 


#15:123 


Motorola 68000 


#19:121 


Motorola 6809 


#15:103 


Motorola 6809 (MDOS09) 


#17:102 


Nord 10 and 100 (Sintran III) 


#15:121 


Perkln-Elmer 3220 


#15:122 


Perkin-Elmer 7/16 


#15:121 


RCA 1802 


#17:103 


RCA 1802 


#15:122 


Siemens 7 .748 


#15:124 


Sperry-Univac V77 


#15:124 


Texas Instruments 990 


#17:101 


Texas Intruments 9900 


#15:124 


Zilog Z-80 


#15:124 


Zilog Z-80 


#19:123 


Zilog Z-80 


#15:124 


Zilog Z-80 


#17:88 


Zilog Z-80 


#17:104 


Zilog Z-80 (CP/M) 


#17:103 


Zilog Z-80 (TRS-80) 


#15:124 


Zilog Z-80 (TRS-80) 


#19:124 


Zilog Z80 


#15:118 


Zilog Z80 


#15:119 


Zilog Z8000 


#15:119 



Applications 



EM1 COMPILER 



^include 
#include 



.. /h/ local. h" 
../h/em1.h" 



4 {(c) copyright 1980 by the Vrije Universiteit, Amsterdam, The Nether- 

5 lands. Explicit permission is hereby granted to universities to use 

6 or duplicate this program for educational or research purposes. All 

7 other use or duplication by universities, and all use or duplica- 

8 tion by other organizations is expressly prohibited unless written 

9 permission has been obtained from the Vrije Universiteit. Requests 

10 for such permissions may be sent to 

12 Dr. Andrew S. Tanenbaum 

13 Wiskundig Seminarium 

14 Vrije Universiteit 

15 Postbox 7161 

16 1007 MC Amsterdam 

17 The Netherlands 

19 Organizations wishing to modify part of this software for subsequent 

20 sale must explicitly apply for permission. The exact arrange- 

21 ments will be worked out on a case by case basis, but at a minimum 

22 will require the organization to include the following notice in all 

23 software and documentation based on our work: 



25 
26 
27 
28 
29 

31 
32 



This product is based on the Pascal system 
developed by Andrew S. Tanenbaum, Johan W. Stevenson 
and Hans van Staveren of the Vrije Universiteit, Amster- 
dam, The Netherlands. 



{if next line is included the compiler is written in standard pascal} 
{#define STANDARD 1} 



34 
35 



{if next line is included, 
{#define SEGMENTS 



then code is produced for segmented memory} 
1} 



37 {Author: Johan Stevenson Version: 31} 

38 {$1- : no source line numbers} 

39 {$r- : no subrange checking} 

40 {$a- : no assertion checking} 

41 #ifdef STANDARD 

42 {$s+ : test conformancy to standard} 

43 #endif 

45 program pem( input ,em1 , errors); 

46 { This Pascal compiler produces EMI code as described in 

47 - A. S. Tanenbaum, J.W.Stevenson & H. van Staveren, 

48 "Description of a experimental machine architecture for use of 

49 block structured languages" Informatika rapport 54. 

50 A description of Pascal is given in 

51 - K.Jensen & N.Wirth, PASCAL user manual and report, Springer-Verlag. 

52 Several options may be given in the normal pascal way. Moreover, 

53 a positive number may be used instead of + and -. The options are: 

54 a: interpret assertions (+) 

55 c: C-type strings allowed (-) 

56 d: type long may be used (-) 



57 
58 
59 
60 
61 
62 
63 
64 
65 
66 
67 
68 
69 
70 



f : size of reals in words (2) 

i: controls the number of bits in integer sets (16) 

1: insert code to keep track of source lines (+) 

o: optimize (+) 

p: size of pointers in words (1) 

r: check subranges (+) 

s: accept only standard pascal programs (-) 

t: trace procedure entry and exit (-) 

u: treat ' f as letter (-) 



} 
{=============== 

#ifdef STANDARD 
label 9999; 
#endif 



72 



const 



74 
75 
76 
77 
78 
79 



{powers of two} 
t7 
t8m1 
t8 
t14 
t15m1 



= 128; 
= 255; 
= 256; 
= 16384; 
= 32767;. 



81 
82 
83 
84 
85 
86 
87 
88- 

90 

91 

92 

93 

94 

95 

96 

97 

98 

99 

100 

101 

103 
104 
105 
106 
107 
108 
109 
110 
111 
112 



{EM-1 sizes} 

bytebits = 

wordbits = 

wbml = 

minint = 

max in t = 

maxintstring = 

max long string = 



16; 

15; 

-t15m1; 

t15m1; 

'0000032767' 

•2147483647' 



{wordbits-1 } 



bytesize =1; 

wordsize =2; 

addrsize = wordsize; 

pnumsize = wordsize; 

shortsize = wordsize; 

longsize =4; 
#ifdef SFLOAT 

floatsize =4; 
#endif- 
#ifndef SFLOAT 

floatsize = 8; 
#endif 

{Pascal sizes, for ptrsize, realsize and fhsize see handleopts} 

{ EM-1 requires that objects greater than a single byte start at a 
word boundary, so their address is even. Normally, a full word 
is also allocated for objects of a single byte. This extra byte 
is really allocated to the object, not only skipped by alignment, 
i.e. if the value false is assigned to a boolean variable then 
both bytes are cleared. For single byte objects in packed arrays 
or packed records, however, only one byte is allocated, even if 
the next byte is unused. Strings are packed arrays. The size of 
pointers is 2 by default, but can be changed at runtime by the 



113 
114 
115 
116 
117 
118 
119 
120 
121 
122 

124 
125 
126 
127 
128 
129 



p-option. Floating point numbers in EM-1 currently have size 4, 
but this might change in the future to 8. The default can be 
overwritten by the f-option. The routines involved with align- 
ment are 'even', 'address' and 'arraysize'. 



} 

boolsize 
char size 
intsize 
buff size 
max set size 



= byte size; 
= bytesize; 
= shortsize; 
= 512; 
= 4096; 



{maximal indices} 

idmax = 8; 

fnmax =14; 

smax = 72; 

rmax = 72; 

imax = 10; 



{t15 div bytebits} 



131 
132 
133 

135 
136 
137 



{opt values} 
off 



= 0; 
= 1; 



{for push and pop: } 
global = false; 
local = true; 



139 
140 
141 



{set bounds} 
minsetint 
max set in t 



= 0; 
= 15; 



{default} 



143 
144 
145 
146 
147 
148 
149 
150 
151 



{constants describing the compact EM1 code} 



MAGIC LOW 

MAGIC HIGH 

meserror 

mesoptoff 

mesvirtual 

mesreg 

meslino 

mesfloats 



= 172; 
= 0; 
= 0; 
= 1; 
= 2; 
= 3; 
= 4; 
= 5; 



153 
154 
155 
156 
157 
158 

160 
161 
162 
163 
164 
165 
166 



{ASCII characters} 
tab r 9; 

newline =10; 

hortab =11; 

formfeed = 12; 

carret = 13r 



{miscellaneous} 
maxsg 
max char ord 
maxargc 
rwlim 
spaces 
emptyfnam 



= 127; 

= 127; 

= 13; 

= 34; 



{maximal segment number} 
{maximal ordinal number of chars} 
{maximal index in argv} 
{number of reserved words} 



168 



{- 



169 


type 


170 


{scalar types} 


171 


symbol= 


172 




173 




174 




175 




176 




177 




178 




179 




180 




181 


chartype= 


182 




183 




184 




185 




186 




187 




188 




189 




190 


standpf= 


191 


- 


192 




193 




194 




195 




196 




197 




198 


libmnem= 


199 




200 




201 




202 




203 




204 




205 


- 


206 




207 




208 




209 




210 


struct form= 


211 




212 


structflags 


213 


id ent flag= 


214 


idclasss 


215 


kindofpf= 


216 


where= 


217 


at tr kinds 


218 


twostructs 


219 




221 


h {subrange type 


222 


sgranges 


223 


idranges 


224 


fnranges 



(comma, semicolon, col on 1,colon2,notsy,lbrack,ident, 
intcst .charcst , realcst .longest ,str ingest ,nilcst ,minsy, 
plussy.lparent, arrow, arraysy,recordsy,setsy,filesy, 
packed sy, prog sy, label sy,constsy,typesy,varsy,procsy, 
funcsy,beginsy,gotosy,ifsy,whilesy,repeatsy,forsy, 
withsy, case sy, becomes, star sy,divsy,modsy, si ashsy, 
andsy,orsy,eqsy,nesy,gtsy,gesy,ltsy, 
lesy.insy, end sy.elsesy, until sy, of sy.dosy, 
downtosy,tosy,thensy,rbrack,r parent, period 
); {the order is important} 

(lower .upper .digit, layout ,tabch, 

quotech,dquotech,colonch,periodch,lessch, 
greaterch,lparentch,lbracech, 

{different entries} 
rpar entch , lbrackch ,rbr ackch ,commach , semich , arrowch , 
plusch, minch, slash, star , equal , 

{also symbols} 
others 
); 

(pread,preadln,pwrite,pwriteln,pput ,pget, 
preset, prewrite,pnew,pdispose,ppack, pun pack, 
pmark.prelease ,ppage,phalt, 

{all procedures} 
feof.feoln.fabs.fsqr.ford.fchr .fpred.fsucc.fodd, 
f trunc.f round, f sin, f cos, fexp.fsqrt.f In, farctan 

{all functions} 
); {the order is important} 

(ELN ,EFL ,CLS ,WDW , {input and output} 

0PN ,GETX,RDI ,RDC ,RDR ,RDL ,RLN , 

{on inputfiles} 
CRE .PUTX.WRI ,WSI ,WRC ,WSC-,WRS ,WSS ,WRB , 
WSB ,WRR ,WSR ,WRL, WSL, WRF ,WRZ ,WSZ ,WLN ,PAG , 

{on output files, order important} 
ABR ,RND ,SIN ,C0S .EXPX.SQT ,L0G ,ATN , 

{floating point} 
ABI ,ABL ,BCP ,BTS ,NEWX,SAV ,RST ,INI ,HLT , 
ASS ,GT0 ,PAC ,UNP, DIS, ASZ, MDI, MDL 

{miscellaneous} 
); 

(scalar .subrange, pointer .power .files, arrays, carray, 
records, variant, tag); {order important} 

(spack,withfile); 

(refer .used .assigned ,noreg .samesect) ; 
(types, konst ,vars, field ,carrbnd ,proc ,func) ; 
(standard, formal, actual, extrn.forwrd); 
(blck.rec.wrec); 

(est .fixed ,pf ixed .loaded .ploaded .indexed) ; 
(eq.subeq.ir.ri.il.li.lr ,rl,es,se,noteq); 

{order important} 



0. .maxsg; 
1 . . idmax ; 
1.. fnmax; 



225 
226 

228 
229 
230 
231 
232 
233 

235 
236 
237 
238 
239 
240 

2*2 
243 
244 

246 
24? 
248 
249 
250 
251 
252 
253 
254 
255 
256 

258 
259 
260 
261 
262 
263 
264 

266 
267 
268 
269 
270 
271 
272 
273 
274 
275 
276 
277 
278 
279 
280 



rwr ange= 
bytes 



0.»rwlim; 
0..t8mi; 



{pointer types} 
spt "structure; 
ip= "identifier; 
ip± "labl; 
bp* "bloekinfo; 
iip= "nameinfo ; 



J set types} 
sos* 

set© fid s= 
forsrsete 
sflagset* 
iflagseta 



set of symbol; 
set of idol ass; 
set of structform; 
set of structflag; 
set of identflag; 



(array types} 
alpha = packed array! idrange] of char; 
fn type a packed a****ayCfnrange] of char; 



{record types} 
erree= record 

ern©:integer; 

messtalpha; 

aesiUnteger; 

ehno: integer; 

lino: integer; 

linr:integer; 

or ig: integer; 

fnamrfntype; 
end; 

position=reeord 
ad: integer; 
iv : integer ; 

#ifdef SEGMENTS 
sg:sgrange 

#endif 



{error number} 

{identifier parameter if required} 

{numeric parameter if rehired} 

{column number} 

{line lumber} 

{relative to start of { included) file} 

{idem, but before preprocessing} 

{source file name} 



{the addr info of certain variable} 
{for locals it is the byte offset} 
{the level of the beast} 

{only relevant for globals (lv-0) } 



{records of type attr are used to remember qualities of 
expression parts to delay the loading of them. 
Reasons to delay the loading of one word constants: 

- bound checking 

- set building. 

Reasons to delay the loading of direct accessible objects: 

- efficient handling of read/write 

- efficient handling of the with statement. 



} 



attr = record 

asp:sp; {type of expression} 

packbit:b©olean; {true for packed elements} 

ak:attrkind; {access method} 

pos: posit ion; {sg, lv and ad} 

{If ak=cst then the value is stored in ad} 



281 



end; 
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287 
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292 
293 
294 
295 
296 
297 
298 

300 
301 
302 
303 
304 
305 
306 
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309 
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314 
315 
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318 
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320 
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322 
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nameinfo=record 
nlink:np; 
fname:ip; 
case occur :where of 

blckiO; 

rec: <); 

wrec:(wa:attr) 



{one for each separate name space} 

{one deeper} 

{first name: root of tree} 



{name space opened by with statement} 



bloc kin fo= record 

nextbp:bp; 

lc: integer; 

ilbno: integer; 

forwcount : integer ; 

lGhain:lp; 
end; 



{all info of the current procedure} 
{pointer to blockinfo of surrounding proe} 
{data' location counter (from begin of proe) 1 
{number of last local label} 
{number of not yet specified forward proes} 
{first label: header of chain} 



str ucture= record 
size; integer; 
sflag:sflagset; 
case form:structform of 
scalar : ( scalno :integer ; 
fconst:ip 
); 
subrange : (min »max : integer ; 
rangetypersp; 
subrao : integer 

); 

pointer :(eltype:sp); 
power : ( el set ; s p ) ; 
files :<filtype:sp); 
arrays .carray: 

(aeltype:sp; 

inxtype:sp; 

arpos:position 

); 

records :(fstfld:ip; 
tagsp:sp 

); 

variant : { varval :integer ; 
nxtvar:sp; 
subtsp:sp 

); 

tag :(fstvar:sp; 

tfldsp:sp 
) 
end; 



{size of structure in bytes} 
{flag bits} 

{number of range descriptor} 
{names of constants} 

{lower and upper bound} 

{type of bounds} 

{number of suhr descriptor} 

{type of pointed object} 
{type of set elements} 
{type of file elements} 

{type of array elements} 
{type of array index} 
{position of array descriptor} 

{points to first field} 
{points to tag if present} 

{tag value for this variant} 
{next e qui level variant} 
{points to tag for sub-case} 

{first variant of ease} 
{type of tag} 



331 
332 
333 
334 
335 
336 



identifiers record 
idtype:sp; 
name:alpha; 
11 ink, r link rip; 
next:ip; 
iflag:iflagset; 



{type of identifier} 

{name of identifier} 

{see enter id .searchid} 

{used to make several chains} 

{several flag bits} 
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360 
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case kl ass: id class of 
types ?(); 
konst :( value: integer) J {for integers the value is 

computed and stored in this field. 

For strings and reals an assembler constant is 

defined labeled ».1\ ' .2», ... 

This ♦.* number is then stored in value. 

For reals value may be negated to indicate that 

the opposite of the assembler constant is needed. 



vars :(vpos:position); 
field Hfoff set: integer); 
carrbnd :(); 
proc.func: 



(case pf kind :kindof pf of 
standard :( key: stand pf) ; 
formal .actual .forwrd .extrn : 
(pfpos:position; 



{position of var) 

{offset to begin of record) 

{idtype points to carray) 1 



{identification} 



) 



{IV gives declaration level. 

sg gives instruction segment of this proc and 

ad is relevant for formal pf's and for 

functions (no conflict!!). 

for functions: ad is the result address. 

for formal pf f s: ad is the address of the 

descriptor } 
pfno: integer; {unique pf number) 

parhead:ip; {head of parameter list) 

headlc: integer {lc when heading scanned) 



end; 
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labl* record 

nextlpilp; 
seen:boolean; 
labval: integer; 
labname: integer ; 
labdlb: integer 

end; 



{chain of labels) 

{label number given by the programmer) 
{label number given by the compiler) 
{zero means only locally used, 

otherwise dlbno of label information) 



{ 

var (the most frequent 

sy t symbol; 

a:attr; 
{returned by insym) 

oh j char; 

chsyschartype ; 

valt integer; 

ix: integer; 

eol:boolean; 

zerostr ing :boolean ; 

id: alpha; 
{some counters) 

lino: integer; 

dlbno: integer; 

lemaxj integer ; 

level Mnteger; 



used externals are declared first) 

{last symbol) 

{type .access method. position, value of expr) 

{last character) 

{type of ch, used by insym) 

{if last symbol is an constant ) 

{string length) 

{true if current eh replaces a newline) 

{true for strings in " ") 

{if last symbol is an identifier) 

{line number on code file (1..n) * 
{number of last global number) 
{keeps track of maximum of lc) 
{current static level) 
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ptr si ze : integer ; 
realsize :integer ; 
fhsize: integer; 
argc: integer; 
last pf no : integer ; 
copt: integer; 
dopt: integer; 
iopt:integer; 
sopt:integer ; 



{file header size) 

{index in argv) 

{unique pf number counter) 

{C-type strings allowed if on) 

{longs allowed if on) 

{number of bits in sets with base integer) 

{standard option) 



{pointers pointing to standard types) 
real ptr .intptr .textptr .emptyset .boolptr :sp; 
charptr .nilptr ,stringptr.longptr:sp; 

{flags} 



{give source line number at next statement) 

{no LIN's for included code) 

{quit without error if true (nextch) } 

{complete programme or a module) 

{true if nested in typedefinition) 

{true if floating point instructions are used) 

{indicates the second dot of '..'} 

{head of chain of forward reference pointers) 
{program identifier} 

{current proc/func ip (see c ase statement ) } 
{pointer to the most recent name space) 
{pointer to nameinfo of last searched ident } 

{all info to be stacked at pf declaration) 
{all info required for error messages) 
{attr for current file name) 



giveline:boolean; 
incl ud ing :bool ean ; 
eofexpected :boolean ; 
main :boolean ; 
intypedec :boolean ; 
f ltused :boolean ; 
seconddot :boolean ; 
{pointers} 
fwptr;ip; 
progp:ip; 
currprocrip; 
top:np; 
lastnp:np; 
{records} 
b:blockinfo; 
ererrec; 
fa:attr; 
{arrays} 
source :fntype; {name of pascal source file} 

strbuf : array t 1 . . smax 3 of char ; 
iop:array[ boolean 3 of ip; 

{false: standard input, true:standard output} 
rw:array[rwrange3 of alpha; 

{reserved words} 
frw:array[0. .idmax3 of integer; 

{indices in rw) 
rsy:array[rwrange3 of symbol; 

{symbol for reserved words} 
cs:array[char3 of chartype; 

{chartype of a character} 
csy:array[rparentch. .equal) of symbol; 

{symbol for single character symbols} 
lmn:array[libmnem3 of packed array! 1.. 43 of char; 

{mnemonics of pascal library routines} 
opt:array['a' ..'z'3 of integer; 
forceopttarrayC'a'.^z 1 ) of boolean; 

{26 different options} 
undefip:array[idclass3 of ip; 

{used in searchid} 
argv : arr ay[0..maxargc3 of 

record name: alpha; ad: integer end; 

{save here the external heading names) 
{files} 
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474 
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em1:file of byte; {the EM1 code* 

errors :file of errec; 

{the compilation errors} 



{= 



= } 



procedure gen2bytes(b:byte; irinteger); 

var b1,b2:byte; 

begin 

if i<0 then 

if Kminint then begin b1:=0; b2:=t7 end 

else begin i:=-i-1; b1:=t8m1 - i mod t8; b2:=t8m1 - i div t8 end 
else begin b1:=i sod t8; b2:=i div t8 end; 
write(em1,b,b1,b2) 
end; 

procedure gencst(i:integer); 
begin 

if (i>=0) and (i<sp_ncst0) then write(em1 ,i+sp_fcst0) 

else gen2bytes(sp_cst2 f i) 
end; 

procedure genclb(irinteger); 

begin if i<t8 then write (em1 ,sp_ilb1 ,i) else gen2bytes(sp_ilb2,i) end; 

procedure gen ilb( irinteger); 
begin lino: =lino+1; 

if i<sp_nilbO then write(em1 t i+sp_filb0) else genclb(i); 
end; 

procedure gendlbC i rinteger) ; 

begin if i<t8 then write (em1,sp_dlb1 ,'i) else gen2bytes(sp_dlb2,i) end; 

procedure genO ( b :byte ) ; 

begin write (emlyb); lino:=lino+1 end; 

procedure gen1(b:byte; irinteger); 
begin gen0(b); gencst(i) end; 

procedure gend(brbyte; d: integer); 
begin genO(b); gendlb(d) end; 

procedure gen id entCnametype: byte; var a: alpha); 
var i,j:integer; 
begin i:=idmax; 

while (aCi]=' *) and (i>1) do i:=i-1; 

write (em1,nametype,i); _ 

for j:=1 to i do write(em1 ,ord(at j])) 
end; 

procedure gensp(m:libmnem); 

var irinteger; 

begin gen0(op_cal); write (em1,sp_pnam, 4); 

for i:=1 to 4 do write(em1 ,ord(lmn[m][i])) 
end; '_.'.-■ 



504 



procedure genpnam( b:byte ; f i'p :ip) ; 



505 var n: alpha; i f j:integer; 

506 begin 

507 if fip".pfpos.ly<=1 then n:=fip".name else 

508 begin n:='_ '; j:=1; irrfip'.pfno; 

509 while i<>0 do 

510 begin j:=j+1; n[j]:=chr(i mod 10'+ ord('0»)); i:=i div 10 end; 

511 end; 

512 gen0(b); genident(sp_pnam,n) 

513 end; 

515 procedure genend; 

516 begin write (em1 ,sp_cend) end; 

518 procedure genlin; 

519 begin giveline:=false; 

520 if opt['l f ]<>off then if main then gen1(op_lin,e.orig) 

521 end; 

523 procedure genreg(ad,sz,nr :integer); 

524 begin 

525 if sz<=wordsize then 

526 begin gen 1(ps_mes ,mesr eg); gencst(ad); gencst(nr); genend end 

527 end; 



529 



{= 



= } 



531 procedure puterrC err: integer); 

532 {as you will notice, all error numbers are preceded by *+' and '0' to 

533 ease their renumbering in case of new errornumbers. 

534 } 

535 begin e.erno:=err; wr i te( error s,e); 

536 if err>0 then begin genl (ps_mes,meserror); genend end 

537 end; 

539 procedure error (err: integer); 

540 begin e.mess:=spaces; e.mesi:=. -1; puterr(err) end; 

542 procedure errid (err: integer ; var id:alpha); 

543 begin e.mess:=id; e.mesi:= -1; puterr(err) end; 

545 procedure err int( err: integer; i:integer); 

546 begin e.mesi:=i; e.mess:=spaces; puterr(err) end; 

548 procedure asperr( err: integer ) ; 

549 begin if a.aspOnil then begin error(err); a.asp:=nil end end; 

551 procedure teststandard; 

552 begin if soptO off then error (-(+01)) end; 

554 procedure en ter id (fip: ip); 

555 {enter id pointed at by fip into the name-table, 

556 which on each declaration level is organised as 

557 an unbalanced binary tree} 

558 var nam:alpha; lip,lip1:ip; lleft, again rboolean; 

559 begin nam :=fip*. name; again :=false; 

560 lip:=top".fname; 



561 if lip=nil then top". f name :=fip else 

562 begin 

563 repeat lip1:=lip; 

564 if lip".name>nam then 

565 begin lip: slip". 11 ink; lleft:=true end 

566 else 

567 _• begin if lip~.name=nam then again : =true ; {name conflict} 

568 lip:=lip".rlink; lleft :=false; 

569 end; 

570 until lips nil; 

571 if Heft then lipl" .llink:=fip else lipl" .rlink:=fip 

572 end; 

573 fip".llink:=nil; fip~.rlink:=nil; 

574 if again then err id (+02, nam); 

575 end; 

577 procedure initpos(var prposition); 

578 begin p.lv:=level; p.ad:=0; 

579 #ifdef SEGMENTS 

580 p.sg:=0 

581 #endif 

582 end; 

584 procedure inita(fsp:sp; fad: integer); 

585 begin with a do begin 

586 asp:=fsp; packbit:=false; ak:=fixed; pos.ad:=fad; pos.lv :=level; 

587 #ifdef SEGMENTS 

588 pos.sg:=0; 

589 #endif 

590 end end; 

592 function newip(kl:idclass; n:alpha; idt:sp; nxt:ip):ip; 

593 var p:ip; f :iflagset; 

594 begin f:=[]; 

595 case kl of 

596 types, carrbnd: {similar structure} 

597 new(p, types); 

598 konst : 

599 begin new(p, konst ); p~. value :=0 end; 

600 vars: 

601 begin new(p,vars); f:=[used, assigned]; initpos(p~.vpos) end; 

602 field: 

603 begin new(p, field); p".foffset:=0 end; 

604 proc,func: {same structure} 

605 - begin new(p,proc, actual); p~.pfkind:=actual; 

606 initpos(p'.pfpos); p".pfno:=0; p".parhead:=nil; p".headlc:=0 

607 end 

608 end; 

609 p~.name:=n; p~.klass:=kl; p*.idtype:ridt; p~.next:=nxt; 

610 _ p".llink:=nil; p".rlink:=nil; p~.iflag:=f; newip:=p 

611 end; 

613 function newsp(sf :structform; sz: integer ):sp; 

614 var p:sp; sflag:sflagset; 

615 begin sflag:=[]; 

616 case_sf of 



617 scalar: 

618 begin new(p, scalar); p~.scalno:=0; p". f const :=nil end; 

619 subrange: 

620 new(p, subrange); 

621 pointer: 

622 begin new(p.pointer); p".eltype:=nil end; 

623 power: 

624 new(p, power); 

625 files: 

626 begin new(p, files); sflag:=Cwithfile] end; 

627 arrays, car ray: {same structure} 

628 new(p, arrays); 
£29 records: 

630 new(p, records) ; 

631 variant: 

632 new(p, variant); 

633 tag: 

634 hew(p,tag); 

635 end; 

636 p~.form:=sf ; p~.size:=sz; p".sflag:=sflag; newsp:=p; 

637 end; 
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procedure initl; 
var c:char; 
begin 

{initialize the first name space} 

new(top,blck); top". occur :=blck; top*. nl ink: 

level :=0; 
{reserved words} 



:nil; top~.fname:=nil; 



rw[ 0] 


s'if ' 


; rw[ 13 


= 'do ' 


; rw[ 23: = 


'of ' 


rw[ 33 


= 'to ' 


; rw[ 43 


= 'in ' 


; rw[ 53: = 


'or ' 


rw[ 6] 


= 'end ' 


; rw[ 7 3 


= ' for ' 


; rw[ 83: = 


'nil ' 


rw[ 9] 


= ' var ' 


rw[103 


='div ' 


; rw[H3: = 


'mod ' 


rw[12] 


='set ' 


rw[133 


= ' and ' 


; rw[l43: = 


•not * 


rw[15] 


= ' then ' 


; rw[163 


='else ' 


; rw[173:= 


•with ' 


rw[18] 


= ' case ' 


; rwd93 


='type ' 


; rw[203: = 


' goto ' 


rw[21 3 


='file ' 


; rw[22 3 


=' begin f 


; rw[233: = 


'until ' 


rw[24] 


='while ' 


; rw[253 


=' array ' 


; rw[263:= 


'const * 


rw[273 


= * label ' 


; rwC281 


=' repeat ' 


; rw[293: = 


'record ' 


rw[30] 


s'downto ' 


; rwi."lj 


=' packed ' 


; rw[323: = 


'program ' 


rwC333 


=' function' 


; vvj{ ) 


= 'procedur ' 






jorresponding symbols} 








rsy[ 03:=ifsy; 


rsy[ 1]:=dosy; 


rsy[ 23: 


=ofsy; 


rsyC 33:=tosy; 


rsy[ 43:=insy; 


rsyC 53: 


=orsy; 


rsyC 63:=endsy; 


rsy[ 73:=forsy; 


rsy[ 83: 


=nilcst; 


rsy[ 93:=varsy; 


rsy[103:=divsy; 


rsy[1l3: 


=modsy; 


rsy[12]:=setsy; 


rsy[133:=andsy; 


rsy[143: 


=notsy; 


rsy[153:=thensy; 


rsy[l63:=elsesy; 


rsy[173: 


=withsy; 


rsy[183:=casesy; 


rsy[193:=typesy; 


rsy[203: 


sgotosy; 


rsy[21]:=filesy; 


rsy[22 3:=beginsy; 


rsy[233: 


=untilsy; 


rsy[243:=whilesy; 


rsy[253:=arraysy; 


rsy[263: 


=constsy; 


rsy[273:=labelsy; 


rsy[283:=repeatsy; 


rsy[293: 


=recordsy; 


rsy[303:=downtosy; 


rsy[31 3: =packedsy ; 


rsy[323: 


=progsy; 


rsy[33 3:=funcsy; 


rsy[343:=procsy; 







{indices into rw to find reserved words fast} 
frw[03:= 0; frwt13:= 0; frw[23:= 6; frw[33:=15; frw[43:=22; 
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frwE5J:=28; frwt63:=32; frwE7I:=33J frwE8I:=35; 
(char types! 
for eisehrCO) to chrCmaxcharord) do est c3: aethers; 
for cJa'O' to *9* do estc3:sdigit; 
for e:a'A* to *2* do estc3: supper; 
for 0:5*3* to *z* do csEc3;=Iower; 
est ohr ( new! ine > 3 s =layout ; 
cstehrChortab) 3 : slayout ; 
est ehrC formfeed) 3 ; ^layout ; 
csEchr (carret)3 : =layout ; 
{characters with corresponding char type in ASCII order} 
est chr C tab > 1 ; stabcb ; 

est * ' * * 3 : adquotech; 

est ' ) ' 3 : srparenteh 

est ' , ' 3 : acommaeh ; 

est V3:=slash; 

cst*<*3:=lessch; 

est * t * 3 : =lbrackch; 

cst*{'3:=lbraeech 



est* '3:=layoiit; 
est * C * 3 : -Iparentch; 
csE'+*3;=plusch; 
est * » * 3 : =per iodeh ; 
est*; *3t=seBiich; 
est *> ' 3 : ^greater ch ; 
est * *^* 3 : »arr oweh ; 



cst'***3:=quotech; 
cs[***3;=star; 
csE'-*3:=B»inch; 
est * : * 3 : =colonch; 
est *»*3:=eojt»al; 
es E * 3 * 3 r =rbrackch ; 



(single character symbols in chartype order} 



esyt rpar enteh3 : arparent ; 
esy t rbr ackch3 : =rbr aek ; 
esy tsemieh3 : =semieolon ; 
csy tpluseh3 : =plussy ; 
esyt slash3 : aslashsy ; 
csy t equal 3 : =eqsy ; 
end; 



csy[ lbrackch3 : =lbraek; 
c sy t coramach3 : aoonaa ; 
esytarrowch.3 : -arrow; 
csytmineh3 ; sminsy ; 
csytstar3:=starsy; 



procedure ir*it2; 

var p,q:ip; k:idclass; 

begin 

{undefined identifier pointers used by searchid} 
for k:stypes to fune do 

undef ip t k3 : =newipC k .spaces ,nil , nil ) ; 
{standard type pointers, some size are filled in by handleopts} 
intptr t = news p( se al ar , i at si ze ) ; 
: snewspC sc al ar , > ; 
:=newsp( scalar ,longsize> ; 
: snewsp( seal ar , ehar si ze > ; 
; =newsp( seal ar »boolsi ze ) ; 
: =newspC pointer ,0 ) ; 
str ingptr : =newspC pointer ,0); 

emptyset :=newsp(power,intsize>; emptyset^.elsettsnil; 
textptr :=newspC files »0>; textptr A .filtype:=charptr; 
{standard type names} 

\ intptr, nil)); 
', real ptr, nil)); 
* t charptr,nil)); 
enteridCnewip(types,*boolean * »boolptr,nil)); 
enter id CnewipC types* 'text ' »textptr ,oil) ) ; 
{standard constant names} 
q :=nil; p:=newipCkonst , * false * t booIptr ,q) ; enterid(p) ; 
q:=p; p;=newip(konst»*true *,boolptr,q); p*«value:=1; enteridCp); 
boolptr^.f const :=p; 

p:=newipCkonst»*maxint ** intptr »oil>; p A .value:=maxint; enteridCp); 
p :=newip(konst .spaces *charptr ,nil) ; p* .value : =maxcharord ; 



real ptr 
longptr 
charptr 
boolptr 
nilptr 



enter id ( newip ( type s t * integ er 
enter id(newip( types , * real 
enteridCnewipC types, * ehar 



729 
730 

732 
733 
734 
735 
736 
737 
738 
739 
740 
741 
742 
743 
744 
745 
746 
747 
748 
749 
750 
751 
752 
753 
754 
755 
756 
757 
758 
759 
760 
761 
762 
763 
764 
765 
766 
767 
768 
769 
770 
771 
772 
773 
774 
775 
776 
777 
778 
779 

781 
782 
783 
784 



charptr" 1 .f const : =p; 



procedure init3; 

var j:standpf ; p:ip; q:np; 

pfn :arr ay t stand pf} of alpha; 

f t ype : array tfeof.. fare tan 3 of sp; 
begin 

rd procedures/functions} 



(names of standai 
pfntpread 
pfntpwrite 
pfnEpput 
pfnEppage 
pfnEprewrite 
pfnlpdispose 
pfn E pun pack 
pfn tpr el ease 
pfntfeof 
pfnEfabs 
pfnEford 
pfntfpred 
pfnCfodd 
pfnEfround 
pfntfeos 
pfnEfsqrt 
pfnEfarctan 

(parameter types 
ft ype tfeof 
ftypetfabs 
ftypetford 
ftypetfpred 
ftypetfodd 
ftypeEfround 
ftypeEfcos 
ftypetfsqrt 
ftypeE fare tan 



= ! read 
= 'write 
= 'put 
='page 
= 'rewrite 
=' dispose 
=' unpack 
= 'release 
s'eof 
= *abs 
= 'ord 
=*pred 
= *odd 
- ' round 
9* cos 
s'sqrt 
s ' arctan 
of standard functions} 



pfnlpreadln 

pfnEpwriteln 

pfnEpget 

pfnE preset 

pfnEpnew 

pfntppaek 

pfnEpmark 

pfnEphalt 

pfnEfeoln 

pfnEfsqr 

pfnEfchr 

pf nE f succ 

pfnEftrunc 

pfntfsin 

pf nE fexp 

pfntfln 



ftypeE feoln 
ftypeEfsqr 
ftypetfchr 
ftypeEfsuec 
ftypetftrune 
ftypeEfsin 
ftypeE fexp 
ftypeE fin 



:='readln 
:=*writeln 
: = ' get 
: = ' reset 
:=*new 
: 9 ( paok 
: = 'mark 
:='halt 
:s'eoln 
: = ' sqr 
: = ' ehr 
:=*succ 
t='trunc 
: = ' sin 
:='exp 
: = Un 



:=nil; 
: =nil; 
: aintptr ; 
:anil; 

: =nil; 

isrealptr; 
: srealptr ; 
:=realptr; 



3:=nil; 
] : =nil; 

: 9nil; 

:9nil; 

3 ; 9intptr ; 

snil; 
3:=realptr; 
=realptr; 
3:=realptr ; 
(standard procedure/function identifiers} 
for j: spread to phalt do 

begin newCp.proc .standard); p^.klassisproc; 

p^.namerspfntji; p".pfkind:9standard; p^-.keyraj; enteridCp); 
end; 
for j;9feof to fare tan do 

begin new(p,func, standard); p^.klassrsfune; p~.idtype:=ftypeE j3; 
(idtype is used not for result type but for parameter type U } 
p*\name:=pfnEj3; p^.pfkindrsstandard; p A .key;«j; enteridCp); 
end; 
{program identifier} 

progp;=newipCproe , '_main ' f nil, nil); 
(new name space for user externals} 

new(q,blck); q A . occur :=blck; q~.nl ink :=top; q".fname:=:nil; top:=q; 
end; 

procedure init4; 
var c:char; 
begin 

(pascal library mnemonics} 



> 



• - 


_eln'; 






:- 


jwchf' ; 


:* 


_opn * ; 


: a 


rdc 1 ; 


i a 


rln"; 






; s 


ere'; 






J a 


_wsi * ; 


: = 


_wrs'; 


:* 


wsb'; 


:a 


_wrl'; 


:« 


wrf; 


:a 


_wln»; 


:a 


_abr'; 


: = 


cos 1 ; 


I a 


'log 1 ; 


: a 


jatoVi 


: = 


Z bc P f * 


S s 


sav 1 ; 


: = 


Jilt 1 ; 


la 


' jpac ' * 


: a 


^asz* ; 



lmnEGETX3 


»' get* 


ImnERDR ] 


a f _rdr' 


lranCPUTX] 


a*_put' 


lmnEWRC ] 


a »_wre * 


lmnEWSS ] 


a '_WSS * 


ImnEWRR I 


=' wrr* 


InmEWSl ] 


= '_wsl f 


ImnEWRZ ] 


= '_wrz' 


lumEPAG ] 


= ! _pag* 


ImnCRND 3 


a'_rnd' 


lmnEEXPX3 


a' exp' 


lmnEATN 3. 


a'_atn' 


lmnEBTS 3 


a' btS 1 


Irani RST 3 


a'_rst* 


ImnEASS 3 


a '__ass ' 


IranEUNP 3 


a' unp' 


ImnEMDI 3 


a« mdi* 



785 3mn[ELN 3:a»_eln'; ImnEEFL 3:a»_efi' 

786 ImnEWDW 3: 

787 lmnEOPM 3: 

788 IranERDC 3: 

789 lmnERUi 3: 

790 tonECRE 3: 

791 ImnEWSI 3: 

792 tanCWRS 3: 

793 IranEWSB 3: 

794 ImnEWRL 3: 

795 tanEWRF 3: 

796 ImnEWUf 3: 

797 IranEABR 3: 

798 ImnECOS 3: 

799 IranELQG 3: 

800 tonCABL 3; 

801 IranlBCP 3: 

802 InmCSAV 3: 

803 ImnCHLT 3: 

804 tanEPAC 3: 

805 lmnEASZ 3: 

806 {options! 

807 for c;a*a f to 

808 optE f a*3:aon; 

809 opt[ *f ' 3: afloatsize div words! ze 

810 opt E ' i * 3 : amax setint+1 ; 

811 optEU r 3:aon; 

812 optE r o r 3:a Q n; 

813 optt'p^iaaddrslze div wordsize; 

814 optE'r^aon; 

815 sopt:aoff;- 

816 {scalar variables} 

817 b.nextbpianil; 

818 b.le:aO; 

819 baibnoiaO; 

820 b.forweount:aO; 

821 b.lchain:=nil; 

822 e.chnoiaO; 

823 e.lino;a1; 

824 e.linr:=t; 

825 e.origral; 

826 e.fnanuaemptyfnam; 

827 source ; aemptyf nan; 

828 linoiaO; 

829 dlbnojaQ; 

830 argo:a1; 

83 1 lastpfnoraQ; 

832 gtvelineratrue; 

833 including : af alse ; 

834 eof ex pec ted : af al se ; 

835 int yped ec ; =f al se ; 

836 fltusediafalse; 

837 seconddot;afalse; 

838 ioptfalse3:anil; 

839 iopEtrue3:anii; 

840 argvE03.ad:=-t; 



lmnECLS 3: axels' 

lmnERDI 3: = ' rdi' 

lmnERDL 3:». , jraV 

lmnEWRI 3:='_wri' 

lmnEWSC 3:a*_j#sc r 

lmnEWRB 3;a'_wrb' 

lmnEWSR 3: a' wsr* 



lmnEWSZ 3j 



wsz' 



ImnESIN 3:a»_sin , ; 
lmnESQT 3:a f _sqt'; 
lmnEABI 3:s'_abi l ; 

lmnENEWX3;a»_new l ; 
lmnEINI 3:= , _ini'; 
ImnEGTO ]:»* gto'; 
lmnEDIS 3:= , _dis»; 
lmnEMDL 3: s» mdl'; 



do begin optEc3:aO; forceoptEc}:afalse end; 

{default real size in words) 

{default pointer size in words) 



841 
842 

844 
845 
846 
847 
848 
849 
850 
851 
852 
853 
854 
855 
856 
857 
858 
859 
860 
861 

863 

865 
866 
867 
868 
869 
870 
871 
872 
873 
874 
875 
876 
877 
878 

880 
881 

883 
884 
885 
886 
887 
888 
889 

891 



894 
895 
896 



argvEl3,ad: 
end; 



-1; 



procedure handleopts; 
begin 

coptraoptE'c^; 
dopt;aoptE'd'3; 
iopt:aoptE'i r 3; 
sopt:=optE's'3; 

realsize:=optE'f'3 * wordsize; realptr^.sizeiarealsize; 
ptrsize:aoptE f p'3 * wordsize; nilptr".size:aptrsize; 
fhsize:a6*intsize + 2*ptrsize; 

textptr" .size : =fhsize+buf f size ; stringptr" .size : aptrsize; 
if soptOoff then begin copt:=off; dopt:=off end 
else if optE'u'3<>off then csE '_' 3: slower; 

if coptOoff then en ter id (newipC types, 'string ' ,stringptr ,nil)); 
if doptOoff then enterid(newip(types,'long ' ,longptr,nil)); 
if optE'o'3aoff then begin gen1(ps_mes,mesoptoff); genend end; 
if ptrsizeOwordsize then begin gen1(ps_mes,mesvirtual); genend end; 
if doptOoff then fltusedrstrue; {temporary kludge) 
end; 



{= 



= ) 



procedure traceCtname: alpha; fip:ip; var namdlbrinteger); 

var i: integer; 

begin 

if optE«t'3<>off then 
begin 
if namdlbaO then 

begin dlbno:adlbno+1; namdlb:adlbno; gendlb(dlbno); 
gen0(ps_rom); writeCeral ,sp_scon,8); 

for i:al to 8 do write (em1,ord(fip".nameEi3)); genend; 
end; 
gen 1 ( op_mrk , ) ; gend ( op_lae , namdlb ) ; 
gen0(op_cal ) ; genident( sp_pnam ,tname) ; 
end; 
end; 

function formof(fsp:sp; forms :formset):boolean; 

begin if fspanil then formof rafalse else formof :afsp".form in forms end; 

function si zeof(fsp:sp): integer ; 
var srinteger; 
begin s:=0; 

if fspOnil then s:afsp~.size; 

if s<>1 then if odd(s) then s:as+1: 

sizeof ;as 
end; 

function ev en (irinteger): integer; 

begin if odd(i) then i:ai+1; evenrai end; 

procedure exchange ( 11 ,12: integer); 

var dt,d2: integer; 

begin d1 : ai2-H ; d2: =lino-12; 



897 
898 
899 

901 
902 

904 
905 
906 
907 
908 

910 
911 
912 
913 
914 
915 
916 
917 
918 

920 
921 
922 
923 
924 
925 
926 
927 
928 

930 
931 

933 
"934 
935 
936 
937 
938 
939 
940 
941 
942 
943 
944 
945 

947 
948 

950 
951 
952 



if (dlOO) and (d2O0) then 

begin gen 1 (ps_exc ,d1 ) ; gencst ( d2 ) end 



procedure setop(m:byte); 

begin gen1(m,even(sizeof(a.asp))) end; 

procedure expandemptyset(fsp:sp); 

var i: integer; 

begin 

for i:=2 to sizeof(fsp) div word size do gen1(op_loc,0); a.asp:=fsp 



procedure push ( local :boolean; ad: integer; sz: integer); 
begin assert not odd(sz); 
if sz> word size then 

begin if local then gen1(op_lal,ad) else gen1(op_lae f ad); 
gen1(op_loi,sz) .-._". 



if local then gen1(op^lol,ad) else gen1(op__loe,ad) 



procedure pop( local rboolean ; ad: integer; sz: integer); 
begin assert not odd (sz); 
if sz> word size then 

begin if local then gen 1 ( op_lal , ad ) else gen 1 ( op_lae , ad ) ; 

genl (op_sti ,sz) 
end 
else 

if local then gen1(op_stl,ad) else gen1(op_ste,ad) 



procedure lexical (m:byte; lv:integer; ad:integer; sz:integer); 
begin gen1(op_lex,level-lv); gen1(op_adi,ad); gen1(m,sz) end; 

procedure load pos( var p:position; sz:integer); 
begin with p do 
if lv<=0 then 
fifdef SEGMENTS 
if sg<>0 then 

begin gen 1(op_lsa,sg) ; gen1(op_adi,ad); gen1(op_loi,sz) end 
else 
#endif 

push( global, ad, sz) 
else 

if ly-level then push( local, ad, sz) else 
lexical (op_loi,lv, ad, sz); 
end; 

procedure descraddr( var prposition) ; 

begin if p.lv=0 then gend(op_lae,p.ad) else loadpos(p.ptrsize) end; 

procedure loadaddr; 
begin with a do begin 
case ak of 



953 fixed: 

954 with pos do 

955 if lv<=0 then 

956 #ifdef SEGMENTS 

957 if sg<>0 then 

958 begin gen1(op_lsa,sg); gen1(op_adi,ad) end 

959 else 

960 #endif 

96 1 gen 1 ( op_lae ,ad ) 

962 else 

963 if lv=level then genl (op_lal,ad) else 

964 begin gen1(op_lex,level-lv); genl (op_adi,ad) end; 

965 pfixed: 

966 loadpos(pos,ptrsize); 

967 ploaded: 

968 ; 

969 indexed: 

970 gen0(op_aas); 

971 end; {case} 

972 ak: uploaded; 

973 end end; 

975 procedure load; 

976 var sz: integer; 

977 begin with a do begin 

978 sz:=sizeof(asp); if not packbit then sz:=even(sz); 

979 if aspOnil then 

980 case ak of 

981 est: 

982 genl (op__loc,pos.ad); {only one-word scalars} 

983 fixed: 

984 loadpos(pos,sz); 

985 pfixed: 

986 begin loadpos( pos, ptr size); gen1(op_loi,sz) end; 

987 loaded : 
988 

989 ploaded: 

990 gen1(op_loi,sz); 

991 indexed: 

992 gen0(op_las); 

993 end; {case} 

994 ak:=loaded; 

995 end end; 



997 procedure store; 

998 var sz:integer; 

999 begin with a do begin 

1000 sz:=sizeof(asp); if not packbit then sz:=even(sz); 

1001 if aspOnil then 

1002 case ak of 

1003 fixed: 

1004 with pos do 

1005 if lv<=0 then 

1006 #ifdef SEGMENTS 

1007 if sg<>0 then 

1008 begin gen1(op_lsa,sg); 



1009 
1010 
1011 
1012 
1013 
1014 
1015 
1016 
1017 
1018 
1019 
1020 
1021 
1022 
1023 
1024 

1026 
1027 
1028 
1029 
1030 

1032 
1033 

1035 

1037 
1038 
1039 
1040 

1042 
1043 
1044 
1045 
1046 
1047 
1048 
1049 
1050 
1051 
1052 
1053 
1054 
1055 
1056 
1057 
1058 
1059 
1060 
1061 

1063 
1064 



genl (op_adi ,ad) ; genl (op_sti ,sz) 
end 
else 



#endif 



else 



pop( global, ad, sz) 



if level=lv then pop( local , ad, sz) else 
lexical(op_sti ,lv ,ad ,sz) ; 
pf ixed : 

begin loadpos(pos.ptrsize); gen1(op_sti,sz) end; 
ploaded : 

gen1(op_sti,sz); 
indexed: 

gen0(op_sas); 
end; {case} 
end end; 

procedure fieldaddK off : integer); 
begin with a do 

if (ak= fixed) and not packbit then pos.ad:=pos.ad+off else 
begin loadaddr; gen1(op_adi,off) end 
end; 

procedure loadcheap; 

begin if formof (a. asp, [arrays.. records]) then loadaddr else load end; 

procedure nextch; 
begin 

eol:=eoln( input); read ( input ,ch); e.chno:=e.chno+1 ; chsy:rcs[ch]; 
end; 

procedure nextln; 
begin 

if eof( input) then 
begin 

if not eofexpected then error (+03) else 
begin 

if fltused then begin gen1(ps_mes,mesfloats); genend end; 
genO (ps_eof ) 
end; 
#ifdef STANDARD 
goto 9999 
#endif 
tfifndef STANDARD 

halt 
# end if 
end; 
e.chno:=0; e.lino:=e.lino+1 ; e.linr :=e.linr+1 ; 
if not including then 

begin e.orig:=e.orig+1 ; giveline:=true end; 
end; 

procedure options(normal:boolean); 
var c,ci:char; itinteger; 



1066 procedure getc; 

1067 var brbyte; 

1068 begin 

1069 if normal then 

1070 begin nextch; c:=ch end 

1071 else 

1072 begin read(eml.b); c:=chr(b) end 

1073 end; 

1075 begin 

1076 repeat getc; 

1077 if (c>=»a') and (c<='z') then 

1078 begin ci:=c; getc; i:=0; 

1 °79 if c='+' then begin i:=1; getc end else 

1080 if c ='-' then getc else 

1081 if csCc]=digit then 

1°82 repeat i:=i*10 + ord(c) - ord('O'); getc; 

1083 until cs[c]Odigit 

1084 else i:=-1; 

1085 if i>=0 then 

1086 if not normal then 

1°87 begin forceopt[ci]:=true; opt[ci]:=i end 

1088 else 

1 °89 if not forceoptCci] then opt[ci]:=i; 

1090 end; 

1091 until c<>','; 

1092 end; 

1094 procedure linedirective; 

1095 var i,j: integer; 

1096 begin i:=0; j:=0; 

1097 repeat nextch until (ch<> f ') or eol; 

1098 while chsy=digit do 

1099 begin i:=i*10 + ord(ch) - ord('O'); nextch end; 

1100 while (ch= ! ') and not eol do nextch; 

1101 if (ch<>"") or (i=0) then error(+04) else 

1102 begin nextch; 

1103 while (ch<>"") and not eol do 

1104 begin 

1105 if ch='/ f then j:=0 else 

1106 begin if j=0 then e.fnam:=emptyfnam; 
11°7 j:=j+1; if j<=fnmax then e.fnam[ j]:=ch; 

1108 end; 

1109 nextch 

1110 end; 

1111 if source= emptyf nam then source :=e.f nam; 

1112 including:=source<>e.fnam; 

1113 i:=i-1; e.linr:=i; 

11 1 4 if not including then e.orig:=i 

1115 end; 

1116 while not eol do nextch; 

1117 end; 

1119 procedure putdig; 

1120 begin ix:=ix+1; if ix<=rmax then strbuf[ix]:=ch; nextch end; 



1122 procedure irtident; 

1123 label 1; 

1124 var i.krinteger; 

1125 begin k:=0; id:=spaces; 

1126 repeat 

1 127 if chsy=upper then ch : =chr ( ord ( ch) -ord ( ' A r )+ord ( • a ' ) ) ; 

1128 if k<idmax then begin k:=k+1; id[k]:=ch end; 

1129 nextch 

113a until chsy>digit; 

1131 {lower=0,upper=1,digit=2. ugly but fast} 

1132 for i:=frw[k-1J to frwCk] - 1 do 
113£ if rwCi]=id then 

1134 begin sy:=rsy[i]; goto 1 end; 

1135 sy:*ident; 

1136 1: 

1137 end; 



1139 procedure innumber; 

1140 label 1; 

1141 const imax = 10; 

1142 var i:integer; 

1143 isipacked arr ayE 1 . . imax ] of char; 

1 1 44 begin ix : =0; sy : =intcst ; val : =0 ; 

1145 repeat putdig until chsyOdigit; 

1146 if (ch=».*) or (ch='e') or (chs'E 1 ) then 

1147 begin 

1148 if ch* 1 .' then 

1149 begin putdig; 

1150 if ch='.' then 

1151 begin seconddot : =true ; ix:six-1; goto 1 end; 

1152 if chsyOdigit then error (+05) else 

1153 repeat putdig until chsyOdigit; 

1154 end; 

1155 if (ch='e') or (chs'E 1 ) then 

1156 begin putdig; 

1157 if (ch= , + f ) or (chr'-O then putdig; 

1158 if chsyOdigit then error (+06) else 

1159 repeat putdig until chsyOdigit; 

1 160 end; 

1161 if ix>rmax then begin error(+07); ix:=rmax end; 

1162 sy:=realcst; f ltused : =true ; dlbno :*dlbno+1; val:=dlbno; 

1163 gend lb (dlbno); gen0(ps_rom); write (em1,sp_rcon,ix); 

1164 for i:=1 to ix do write(em1,ord(strbuf[i])); genend; 

1165 end; 

1166 1:if (chsy= lower) Or (chsy=upper) then teststandard; 

1167 if sy=intcst then 

1168 if ix>imax then error (+08) else 

1169 begin is :=» 0000000000*; i:=imax+1; 

1170 while ix>0 do 

1171 begin i:=i-1; is[i]:=strbufCix]; ix:=ix-1 end; 

1172 if is<=maxint string then 

1173 while i<=imax do 

1174 begin val:=val«10 - ord( f r ) + ord(is[i]); i:=i+1 end 

1175 else if (is<=maxlongstring) and (doptOoff) then 

1176 begin sy:=longcst; dlbno:=dlbno+1; vaI;=dlbno; 
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gendlb( dlbno) ; genO (ps_con) ; wr iteCeml , sp_lcon ,iraax+1 ~i) ; 
while i<=iraax do 

begin write(em1 ,ord(is[il)); i:=i+1 end; 
genend 
end 
else error (+09) 
end 



end; 



procedure in str ing ( qc : c har ) ; 
var i: integer; 

begin ix:=0; zerostring:=qc= M "; 
repeat 

repeat nextch; ix:six+1; if ix<=smax then strbuf [ix]:=ch; 
until (ch=qc) or eol; 
if ch=qc then nextch else error(+010); 
until chOqc; 
if not zero st ring then 

begin ix:=ix-1; if ix=0 then error(+011) end 
else 

begin strbuf[ix]:=chr(0); if copt=off then error(+012) end; 
if (ix=1) and not zerostring then 

begin sy:=charcst; val:sord(strbuf[1 ]) end 
else 

begin sy:=str ingest; dlbno : =dlbno+1 ; val:=dlbno; 
if ix>smax then begin error(+013); ix:=smax end; 
gend lb (dlbno); gen0(ps_rom); writeCeml ,sp_scon,ix); 
for i:=1 to ix do write(em1 f ord(strbuf[i])); genend; 
end 
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procedure incomment; 

var stopc:char; 

begin nextch; stopc:^} 1 ; 

if ch='$' then opt ions( true); 
while (chO'}') and (chOstopc) do 

begin stopc:='}*; if ch='* r then stopcrs')' 
if ch=';» then error(-(+014)); 
if eol then nextln; nextch 



if chO ' } ' 
nextch 
end; 



then teststandard; 



procedure insym; 

{read next basic symbol of source program and return its 
description in the global variables sy, op, id, val and ix} 
label 1 ; 
begin 

1 lease chsy of 
tabch: 

begin e.chno:=e.chno - e.chno mod 8+8; nextch; goto 1 end; 
layout : 

begin if eol then nextln; nextch; goto 1 end; 
lower, upper: inident; 
digit: innumber; 
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quotech.dquotech: 

instring(ch); 
colonch: 

begin nextch; 

if ch='=' then begin sy:=becomes; nextch end else sy:=colon1 
end; 
periodch: 

begin nextch; 

if seconddot then begin seconddot:=false; sy:=colon2 end else 
if chs'. 1 then begin sy:=colon2; nextch end else sy:=period 
end; 
lessch: 
begin nextch; 

if chs's 1 then begin sy:=lesy; nextch end else 
if ch='>' then begin sy:=nesy; nextch end else sy:=ltsy 
end; 
greater ch: 
begin nextch; 

if chs's* then begin sy:=gesy; nextch end else sy:=gtsy 
end; 
lparentch: 
begin nextch; 

if chO 1 *' then sy:=lparent else 
begin teststandard; incomment; goto 1 end; 
end; 
lbracech: 

begin incomment; goto 1 end; 
rparentch,lbrackch,rbrackch,commach t semich,arrowch, 
plusch,minch, slash , star .equal : 

begin sy:=csy[chsy]; nextch end; 
others: 
begin 

if (chs 1 !') and (e.chno=1) then lined irective else 

begin err or (+01 5); nextch end; 
goto 1 
end; 
end toase) 



1272 procedure nextif(fsy: symbol; err: integer); 

1273 begin if sy=fsy then insym else error (-err) end; 

1275 function findl (sys1,sys2:sos; err: integer): boolean; 

1276 {symbol of sysl expected, return true if sy in sysD 

1277 begin 

1278 if not (sy in sysD then 

1279 begin error(err); while not (sy in sys1+sys2) do insym end; 

1280 findl :=sy in sysl 

1281 end; 



1283 function findii(sys1,sys2:sos; err: integer): boolean; 

1284 (symbol of sys1+sys2 expected, return true if sy in sysl} 

1285 begin 

1286 if not (sy in sys1+sys2) then 

1287 begin error(err); repeat insym until sy in sys1+sys2 end; 

1288 find2:=sy in sysl 



1289 



end; 



1291 function find3(sy1: symbol; sys2:sos; err: integer ):boolean; 

1292 {symbol sy1 or one of sys2 expected, return true if sy1 found and skip} 

1293 begin find3:=true; 

1294 if not (sy in Csy1 ]+sys2) then 

1295 begin error (err); repeat insym until sy in [sy1]+sys2 end; 

1296 if sy=sy1 then insym else find3: =false 

1297 end; 

1299 function endofloop(sys1,sys2:sos; sy3:symbol; err : integer): boolean; 

1300 begin endofloop:=false; 

1301 if find2(sys2+[sy3],sys1,err) then nextif(sy3,err+1 ) 

1302 else endofloop:=true; 

1303 end; 

1305 function lastsemicolon(sys1,sys2:sos; err : integer): boolean; 

1306 begin lastsemicolon:=true; 

1307 if not endofloop(sys1,sys2, semicolon, err) then 

1308 if find2(sys2,sys1,err+2) then lastsemicolon:=false 

1309 end; 
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{= 



1313 function searchid(fidcls: setofids):ip; 

1314 {search for current identifier symbol in the name table} 

1315 label 1; 

1316 var liprip; ic:idclass; 

1317 begin lastnp:=top; 

1318 while lastnpOnil do 

1319 begin lip:=lastnp~.fname; 

1320 while lipOnil do 

1321 if lip'.namerid then 

1322 if lip'.klass in fidcls then 

1323 begin 

1324 if lip~.klass=vars then if lip~.vpos.lvO lev el then 

1325 lip*.iflag:=lip".iflag+[noreg]; 

1326 goto 1 

1327 end 

1328 else lip:=lip".rlink 

1329 else 

1330 if lip~.name< id then lip:=lip~.rlink else lip:=lip~.llink; 

1331 lastnp:=lastnp".nlink; 

1332 end; 

1333 errid(+016,id); 

1334 if types in fidcls then ic:=types else 

1335 if vars in fidcls then ic:=vars else 

1336 if konst in fidcls then ic:=konst else 

1337 if proc in fidcls then ic:=proc else 

1338 if func in fidcls then ic:=func else ic:=field; 

1339 lip:=undefip[ic]; 

1340 1: 

1341 searchid:=lip 

1342 end; 



1344 function searchsection(fip: ip):ip; 
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{to find record fields and forward declared procedure id's 

— >procedure pf declaration 

— >procedure selector} 
label 1; 
begin 

while fipOnil do 

if fip~.name=id then goto 1 else 

if fip~.name< id then fip:=fip~.rlink else fip:=fip".llink; 
1: searchsection:=fip 
end; 

function searchlab(flp:lp; val: integer ):lp; 
label 1; 
begin 
while fipOnil do 

if flp".labval=val then goto 1 else flp:=flp~.nextlp; 
1:searchlab:=flp 

end; 

> \ 

procedure opconvert( ts :twostruct ) ; 
var op: integer; 
begin with a do begin 
case ts of 

ir: begin op:=op_cif; asp:=realptr; fltused:=true end; 
ri: begin op:=op_cfi; asp:=intptr; fltused:=true end; 
il: begin op:=op_cid; asp:=longptr end; 
li: begin op:=op_cdi; asp:=intptr end; 
Ir: begin op:=op_cdf; asp:=realptr ; fltused:=true end; 
rl: begin op:=op_cfd; asp:=longptr; fltused:=true end; 
end; 

genO(op) 
end end; 

procedure negate (11: integer); 

var 12: integer; 

begin 

if a.asp=intptr then gen0(op_neg) else 
begin 12:=lino; gen1(op_loc,0); 
if a.asp=longptr then 

begin opconvert(il); exchangedl ,12); gen0(op_dsb) end 
else {realptr} 

begin opconvert(ir); exchange(H ,12); gen0(op_fsb) end 
end 
end; 

function desub(fsp:sp):sp; 
begin 

if formof(fsp,[ subrange]) then fsp:=fsp~.rangetype; desub:=fsp 
end; 

function nicescalar(fsp:sp): boolean; 
begin 

if fsp=nil then n ic esc alar:= true else 
nicescalar: = (fsp".form=scalar) and (fspOrealptr) and (fspOlongptr) 
end; 



1401 function bound s(fsp:sp; var fmin,f max: integer): boolean; 

1402 {compute bounds if possible, else return false} 

1403 begin bound s:=false; fmin:=0; fmax:=0; 

1404 if fspOnil then 

1405 if fsp". form= subrange then 

1 406 begin fmin:=fsp'\min; fmax:=fsp".max; bounds :=true end else 

1407 if fsp~.form= scalar then 

1408 if fsp^.f const <> nil then 

1 409 begin fmin:=0; f max :=fsp".f const ".value; bounds :=true end 

1410 end; 

1412 procedure genrck(fsp:sp); 

1413 var min,max,sno:integer; 

1414 begin 

1415 if optC'r'JOoff then if bounds(fsp,min,max5 then 

1416 begin 

1 417 if fsp". forms scalar then sno:=fsp~.scalno else sno:=fsp".subrno; 

1418 if sno=0 then 

1419 begin dlbno:=dlbno+1 ; sno:=dlbno; 

1420 gendlb(dlbno); genl (ps_rom,min); gencst(max); genend; 

1421 if fsp~.form=scalar then fsp~.scalno:=sno else 

1422 fsp A .subrno:=sno 

1423 end; 

1424 gend(op_rck,sno); 

1425 end 

1426 end; 

1428 procedure checkbnds(fsp:sp); 

1429 var min1,max1,min2,max2:integer ; bool:boolean; 

1430 begin 

1431 if bounds(fsp, mini, maxl ) then 

1432 begin bool:=bounds(a.asp,min2,max2); 

1433 if (bool= false) or (min2<min1) or (max2>max1) then 

1434 genrck(fsp); 

1435 end; 

1436 a.asp:=fsp; 

1437 end; 

1439 function eqstruct(p,q:sp):boolean; 

1440 begin eqstruct:=(p=q) or (p=nil) or (q=nil) end; 

1442 function string(fsp:sp):boolean; 

1443 var lsp:sp; 

1444 begin string:=false; 

1445 if formofCfsp, [arrays]) then 

1446 if eq6truct(fsp~.aeltype,charptr) then 

1447 if spack in fsp'.sflag then 

1448 begin lsp:=fsp".inxtype; 

1449 if lsprnil then string :=true else 

1450 if lsp~.form= subrange then 

1451 if lsp".rangetype=intptr then 

1452 if lsp".min=1 then 

1453 string:* true 

1454 end 

1455 end; 
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function compat(p,q:sp):twostruct; 
begin compat:=noteq; 

if eqstruct(p.q) then compat:=eq else 
begin p:=desub(p); q:=desub(q); 

if eqstruct(p,q) then compat:=subeq else 
if p~.formsq~.form then 
case p~.form of 
scalar: 

if (p=intptr) and (q=realptr) then compat:=ir else 
if (p=realptr) and (q=intptr) then compat:=ri else 
if (p=intptr) and (q=longptr) then compat:=il else 
if (pslongptr) and (q=intptr) then compat:=li else 
if (p=longptr) and (q=realptr) then compat:=lr else 
if (p=realptr) and (q=longptr) then compat:=rl else 

pointer : 

if (p=nilptr) or (q=nilptr) then compat:=eq; 
power : 

if p=emptyset then compat:=es else 
if q=emptyset then compat:=se else 
if compat(p~.elset,q~.elset) <= subeq then 
if p~.sflag=q~.sflag then compat:=eq; 
arrays: 

if string(p) and string(q) and (p~.sizesq~.size) then 
compat:=eq; 
files.carray.records: ; 
end; 
end 
end; 



1487 procedure checkasp(fsp:sp; err : integer); 

1488 var ts:twostruct; 

1489 begin 

1490 ts:=compat(a.asp,fsp); 

1491 case ts of 

1492 eq: 

1493 if fspOnil then if withfile in fsp~.sflag then asperr(err); 

1494 subeq: 

1495 checkbnds(fsp); 

1496 li: 

1497 begin opconvert(ts); checkasp(fsp.err) end; 

1498 il,rl,lr,ir: 

1499 opconvert(ts); 

1500 es: 

1501 expandemptyset(fsp); 

1502 noteq.ri.se: 

1503 asperr(err); 

1504 end 

1505 end; 



1507 procedure force (fsp:sp; err: integer); 

1508 begin load; checkasp(fsp.err) end; 

1510 function newident(kl:idclass; idt:sp; nxt:ip; err :integer):ip; 

1511 begin newident:=nil; 

1512 if syOident then error (err) else 



1513 begin newident:=newip(kl,id,idt,nxt) ; insym end 

1514 end; 

1516 function stringstruct:sp; 

1517 var lsp:sp; 

1518 begin {only used when ix and zerostring are still valid} 

1519 if zerostring then lsp:=stringptr else 

1520 begin lsp: =newsp( arrays, ix*charsize); lsp~.sflag:=[spack3; 

1521 lsp~.aeltype:=charptr ; lsp~.inxtype:=nil; 

1522 end; 

1523 stringstruct:=lsp; 

1524 end; 

1526 function address(var lc:integer; sz:integer; pack :boolean): integer ; 

1527 begin 

1528 if lc >= maxint-sz then begin error (+01 7); lc:=0 end; 

1529 if (not pack) or (sz>1) then if odd(lc) then lc:=lc+1; 

1530 address :=lc; 

1531 lc:=lc+sz 

1532 end; 

1534 function reserve( s: integer): integer ; 

1535 var r:integer; 

1536 begin r:=address(b.lc,s, false); genreg(r,s, 100); reserve:=r; 

1537 if b.lc>lcmax then lcmax:=b.lc 

1538 end; 

1540 function arraysize(fsp:sp; pack:boolean) : integer ; 

1541 var sz,min,max,tot,n:integer; 

1542 begin sz:=sizeof(fsp~.aeltype); 

1543 if not pack then sz:=even(sz) ; 

1544 if bounds(fsp~.inxtype,min,max) then; {we checked before} 

1545 dlbno:=dlbno+1; fsp~.arpos.lv :=0; fsp~.arpos.ad:=dlbno; 

1546 gendlb(dlbno); gen1(ps_rom,min); gencst(max-min) ; 

1547 gencst(sz); genend; 

1548 n:=max-min+1 ; tot:=sz*n; 

1549 if szOO then if tot div sz <> n then begin error(+0l8); tot:=0 end; 

1550 arraysize:=tot 

1551 end; 

1553 procedure treewalk(fip:ip); 

1554 var lsp:sp; i: integer; 

1555 begin 

1556 if fipOnil then 

1557 begin treewalk(fip\.llink) 

1558 if fip~.klass=vars then 

1559 begin if not (used in fip~.iflag) then errid(-(+019),fip~.name); 

1560 if not (assigned in fip~.iflag) then errid(-(+020) f fip~.name); 

1561 lsp:=fip~.idtype; 

1562 if not (noreg in fip~.iflag) then 

1563 genreg(fip~.vpos.ad,sizeof(lsp) ,ord(formof(lsp f [pointer]))); 

1564 if lspOnil then if withfile in lsp~.sflag then 

1565 if lsp~.form= files then 

1566 if level=1 then 

1567 begin 

1568 for i:=2 to argc do with argvCi] do 



treewalk( fip~ .rlink) ; 
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if namesfip^.name then ad:=fip"\vpos.ad 
end 
else 
begin 

if not (refer in fip'.iflag) then 
begin gen1(op_mrk,0); 

gen1(op_lal f fip^.vpos.ad); gensp(CLS) 
end 



if level<>1 then err id (-(+021 ) ,fip".name) 



1584 procedure constant (fsys:sos; var fsprsp; var fval: integer); 

1585 var signed ,m in: boolean; lip:ip; 

1586 begin signed :=(sy=pl ussy) or (sy=minsy); 

1587 if signed then begin min:=sy=minsy; insym end else min:=false; 

1588 if findl ([ident. .nilcst],fsys, +022) then 

1589 begin fval:=val; 

1590 case sy of 

1591 stringcst: fsp:=stringstruct; 

1592 charcst: fsp:=charptr ; 

1593 intcst: fsp:=lntptr; 

1594 realcst: fsp:=realptr ; 

1595 longest: fsp:=longptr ; 

1596 nilcst: fsp:=nilptr; 

1597 ident: 

1598 begin lip:=searchid(Ckonst3); 

1599 fsp: =lip". id type; fval:=lip~. value; 

1600 end 

1601 end; {case} 

1602 if signed then 

1603 if (fspOintptr) and (fspOrealptr) and (fspOlongptr) then 

1604 error(+023) 

1605 else if min then fval:= -fval; 

1606 {note: negating the v-number for reals and longs} 

1607 insym; 

1608 end 

1609 else begin fsp:=nil; fval:=0 end; 

1610 end; 

1612 function cstinteger(fsys:sos; fsp:sp; err : integer): integer; 

1613 var lsp:sp; lval , min , max : integer; 

1614 begin constant (fsys,lsp, lval); 

1615 if fspOlsp then 

1616 if eqstruct(desub(fsp) ,lsp) then 

1617 begin 

1618 if bounds(fsp,min,max) then 

1619 if (lvaKmin) or (lval>max) then error(+024) 

1620 end 

1621 else 

1622 begin error (err); lval:=0 end; 

1623 cstinteger : slval 

1624 end; 
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function typid*( err: integer ):sp; 
var lip:ip; lsp:sp; 
begin lsp:=nil; 

if syOident then error(err) else 

begin lip:=searchid(Ctypes]); lsp: slip". id type; insym end; 

typid : =lsp 
end; 

function simpletyp(fsys:sos):sp; 

var lsp,lsp1:sp; lip,hip:lp; min ,max: integer; lnp:np; 

newsubrange:boolean ; 
begin lsp:=nil; 

if find1([ ident.. lparent],fsys, +025) then 
if sy=lparent then 

begin insym; lnp:=top; {decl. consts local to innermost block} 
while top^.occurOblck do top:=top A .nlink; 
. lsp:=newsp( scalar , word size); hip:=nil; max:=0; 
repeat lip:=newident(konst,lsp,hip,+026); 
if lipOnil then 
begin enterid(lip); 

hip:=lip; lip^.value^max; max:=max+1 
end; 
until endofloop(fsys+[rparent],[ ident], comma, +027); {+028} 
if max<=t8 then lsp^.size^bytesize; 
lsp". f const :=hip; top:=lnp; nextif(rparent,+029); 
end 
else 

begin newsubrange:=true; 
if sy= ident then 
begin lip :=searchid( [types, konst]); insym; 
if lip~.klass= types then 

begin lsp:=lip~.idtype; newsubrange:=false end 
else 

begin lspl: slip". id type; min :=lip~. value end 
end 
else constant (fsys+[colon2, ident.. plussy],lsp1, min); 
if newsubrange then 

begin lsp:=newsp(subrange,wordsize); lsp^.subrno^O; 
if not nicescalar(lspl) then 

begin error(+030); lsp1:=nil; min:=0 end; 
lsp" .rangetype : =lsp 1 ; 

nextif ( colon2 , +031 ) ; max : =cstihteger ( fsys ,lsp1 , +032 ) ; 
if min>max then begin error(+033); max:=min end; 
if (min>=0) and (max<t8) then lsp".size:=bytesize; 
lsp".min:=min; lsp" .max : =max 
end 
end; 
simpletyp:=lsp 
end; 

function arraytyp(fsys:sos; 

artyp:structform; 
sflag:sflagset; 



1681 function element(fsys:sos):sp 

1682 ) :S p; 

1683 var lsp,lsp1,hsp:sp; min.max: integer; oktboolean; sepsytsymbol; lip:Ip; 

1684 oksys:sos; 

1685 begin insym; nextif(lbrack,+034); hsp:=nil; 

1686 repeat lsp:mewsp(artyp,0); initposdsp^.arpos); 

1687 lsp".aeltype:=hsp; hsp:=lsp; {link reversed} 

1688 if artyp=carray then 

1689 begin sepsy:=semicolon; oksys:=[ident]; 

1690 lip:=newident(carrbnd,lsp,nil,+035); 

1691 if lipOnil then enterid(lip); 

1692 nextif(colon2,+036); 

1693 lip:=newident(carrbnd,lsp,lip,+037); 

1694 if lipOnil then enter id (lip); 

1695 nextif(colon1,+038); lsp1:=typid(+039); 

1696 ok:=nicescalar(desub(lspD); 

1697 end 

1698 else 

1699 begin sepsy:scomma; oksys:=[ident..lparent]; 

1700 lsp1:mimpletyp{fsys+[comma,rbrack,ofsy,ident..packedsy]); 

1701 ok:sbounds(isp1,min,niax) 

1702 end; 

1703 if not ok then begin error(+040); lsp1:mil end; 

1704 lsp".inxtype:=lsp1 

1705 until endofloop(fsys+[rbrack,ofsy, ident.. packedsy],oksys, 

1706 sepsy,+041); {+042} 

1707 nextif(rbrack,+043); nextif(ofsy,+044); 

1708 lsp:=element(fsys); 

1709 if IspOnil then sflag :=sflag + lsp'.sflag * [withfile]; 

1710 repeat {reverse links and compute size} 

1 711 lsp1:=hsp".aeltype; hsp~.aeltype:=lsp; hsp~.sflag:= sflag; 

1712 if artyp=arrays then hsp~.size:=arraysize(hsp,spack in sflag); 

1713 lsp:=hsp; hsp:=lsp1 

1714 until hspmil; {lsp points to array with highest dimension} 

1715 arraytyp:=lsp 

1716 end; 



1718 function typ(fsys:sos):sp; 

1719 var lsp,lsp1:sp; oe,sz,min .max: integer; 

1720 sflag: sflag set; lnprnp; 

1722 function fldlist(fsys:sos):sp; 

1723 {level 2: « typ} 

1724 var fip,hip,lip:ip; lsp:sp; 

1726 function varpart(fsys:sos):sp; 

1727 {level 3: « fldlist « typ} 

1728 var tip t lip:ip; lsp,headsp,hsp,vsp,tsp,tsp1,tfsp:sp; 

1729 mlnoc,maxoc,int,nvar: integer; lid: alpha; 

1730 begin ihsym; tip: mil; lip: mil; 

1731 tsp:=newsp(tag,0); 

1732 if syOident then error(+045) else 

1733 begin lid:=id; insym; 

1734 if sy=colon1 then 

1 735 begin tip :mewip( field ,lid, nil ,nil); enterid(tip); 

1736 if syOident then error (+046) else 



insym; 



1737 begin lid:=id; insym end; 

1738 end; 

1739 if sy=ofsy then {otherwise you may destroy id} 

1740 begin id:=lid; lip:rsearchid([types]) end; 

1741 end; 

1742 if lip=nil then tfsp:=nil else tfsp:=lip".idtype; 

1743 if bounds(tfsp,int,nvar) then nvar :=nvar-int+1 else 

1744 begin nvar:=0; 

1745 if tfspOnil then begin error(+047); tfsp:mil end 

1746 end; 

1747 tsp~.tfldsp:=tfsp; 

1748 if tipOnil then {explicit tag} 

1749 begin tip".idtype:=tfsp; 

1750 tip~.foffset:=address(oc,sizeof(tfsp),spack in sflag) 

1751 end; 

1752 nextif(ofsy,+048); minoc:=oc; maxoc:=minoc; headsp:=nil; 

1753 repeat hsp:=nil; {for each caselabel list} 

1754 repeat nvar:=nvar-1; 

1 755 int : =cst in teger ( fsys+ C ident . .plussy , comma .colon 1 , lpar ent , 

1756 semicol on, casesy.r parent], tfsp, +049); 

1757 lsp:=headsp; {each label may occur only once} 

1758 while IspOnil do 

1759 begin if lsp~.varval=int then error(+050); 

1760 lsp:=lsp~.nxtvar 

1761 end; 

1762 vsp:mewsp( variant ,0); vsp~.varval:=int; 

1763 vsp~.nxtvar:=headsp; headsp:=vsp; {chain of case labels} 

1764 vsp^.subtsp^hsp; hsp:=vsp; 

1765 {use this field to link labels with same variant} 

1766 until endofloop(fsys+[colon1,lparent. semicolon, casesy.rparent], 

1767 [ id ent.. plussy], comma, +05 1 >; {+052} 

1768 nextif(colon1,+053); nextif( lpar ent, +054); 

1 769 tspl : =f ldlist ( fsys+Crparent .semicolon .ident . .plussy] ) ; 

1770 if oc>maxoc then maxoc:=oc; 

1771 while vspOnil do 

1772 begin vsp~.size:=oc; hsp:=vsp~.subtsp; 

1773 vsp~.subtsp:=tsp1; vsp:=hsp 

1774 end; 

1775 nextif(rparent,+055); 

1 776 oc : =minoc ; 

1777 until lastsemicolon(fsys,[ ident.. plussy], +056); {+057 +058} 

1778 if nvar>0 then error(-(+059)); 

1779 tsp".fstvar:=headsp; tsp".size:=minoc; oc:=maxoc; varpart:=tsp; 

1780 end; 



1782 begin {fldlist} 

1783 if find2([ ident], fsys+[casesy], +060) then 

1784 repeat lip:=nil; hip: mil; 

1785 repeat f ip:=newident( field, nil, nil, +061 ); 

1786 if fipOnil then 

1787 begin enterid(fip); 

1788 if lipsnll then hip:=fip else lip~.next:=fip; lip:=fip; 

1789 end; 

1790 until endofloop(fsys+[ colon 1, ident.. packedsy, semicolon, casesy], 

1791 [ident], comma, +062); {+063} 

1792 nex ti f( colon 1, +064); 



1793 lsp:=typ(fsys+[casesy, semicolon]); 

1794 if IspOnil then If withfile in lsp". sflag then 

1795 sflag r=sflag+ [withfile]; 

1796 while hipOnil do 

1797 begin hip".idtype:=lsp; 

1798 hip".foffset:=address(oc,sizeof(lsp) ,spack in sflag); 

1799 hip: =hip". next 

1800 end; 

1801 until lastsemicolon(fsys+[casesy],[ident],+065); {+066 +067} 

1802 if syscasesy then fldlist :=varpart(fsys) else fldlist :=nil; 

1803 end; 



1806 begin {typ} 

1807 sflag :=[]; lsp:=nil; 

1808 if sy=packedsy then begin sflag:=[spack]; insym end; 

1809 if find1([ldent..filesy],fsys,+068) then 

1810 if sy in [ id en t.. arrow] then 

1811 begin if spack in sflag then error(+069); 

1812 if sy= arrow then 

1813 begin lsp:=newsp(pointer,ptrsize); insym; 

1814 if not intypedec then lsp".eltyper=typid(+070) else 

1815 if syOident then error(+071 ) else 

1816 begin fwptr :=newip( types, id, lsp, fwptr); insym end 

1817 end 

1818 else lsp:=simpletyp(fsys) ; 

1819 end 

1820 else 

1821 case sy of 

1822 {««««««} 

1823 arraysy: 

1824 lsp:=arraytyp(fsys, arrays, sflag, typ); 

1825 recordsy: 

1826 begin insym; 

1827 new(lnp,rec); lnp". occur :=rec; lnp".nlinkr=top; 

1828 lnp".fname:=nil; top:=lnp; 

1829 oc:=0; lsp1:=fldlist(fsys+[endsy]); {fldlist updates oc) 

1830 lspr=newsp( records, oc); lsp".tagspr=lsp1; 

1831 lsp".fstfld:=top".fname; lsp".sflagr=sflag; 

1832 top:=top".nlink; nextif(endsy,+072) 

1833 end; 

1834 setsy: 

1835 begin insym; nextif(ofsy,+073); lsp1r=simpletyp(fsys); 

1836 if bounds(lsp1,min,max) then lsplr =desub( lsp 1) else 

1837 if IspUintptr then 

1838 begin error(-(+074)); max:=iopt-1 end 

1839 else 

1840 begin error(+075); lsp1:rnil end; 

1841 if lspUintptr then szr=iopt-1 else 

1842 begin if bounds(lsp1,min,max) then {nothing}; szr=max end; 

1843 if (min<0) or (max>sz) or (sz div bytebits >= maxsetsize) then 

1844 begin error(+076); lsp1:=nil; sz:=0 end; 

1845 lsp :=newsp( power ,sz div bytebits +1); lsp".elsetr=lsp1; 

1846 end; 

1847 filesy: 

1848 begin insym; nextif(ofsy,+077); lsp1:=typ(fsys); 



1849 ' if IsplOnil then if withfile in lspl". sflag then error(-(+078)); 

1850 sz:=sizeof(lsp1); if sz<buffsize then sz:=buffsize; 

1851 lsp :=newsp( files, sz+fhsize); lsp". fil type :=lsp1; 

1852 end; 

1853 {»»»»»»} 

1854 end; {case} 

1855 typ:=lsp; 

1856 end; 

1858 function vpartyp(fsys:sos):sp; 

1859 begin 

1860 if find2([arraysy],fsys+[ident],+079) then 

1861 vpartyp:=arraytyp(fsys,carray,[],vpartyp) 

1 862 else 

1863 vpartyp:=typid(+080) 

1864 end; 
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1868 procedure block(fsys:sos; fiprip); forward; 

1869 {pfdeclaration calls block. With a more obscure lexical 

1870 structure this forward declaration can be avoided} 

1872 procedure labeldeclaration(fsysrsos); 

1873 var llprlp; 

1874 begin with b do begin 

1 875 repeat 

1876 if syOintcst then error(+081 ) else 

1877 begin 

1878 if searchlab(lchain,val)Onil then errint(+082,val) else 

1879 begin new(llp); llp~.labval:=val; 

1880 if val>9999 then test standard; 

1881 ilbno:=ilbno+1; llp'Mabname^ilbno; llp".labdlb:=0; 

1882 lip". seen :=false; llp".nextlp:=lchain; lchain:=llp; 

1883 end; 

1884 insym 

1 885 end 

1886 until endofloop(fsys+[semieolon],[intcst], comma, +083); {+084} 

1887 nextifC semicolon, +085) 

1888 end end; 

1890 procedure constdefinition(fsys:sos); 

1891 var lip rip ; 

1892 begin 

1893 repeat lip:=newident(konst,nil,nil,+086); 

1894 if lipOnil then 

1895 begin nextif(eqsy,+087); 

1896 constant ( f sys+ [ semicolon, id ent] , lip" .idtype ,lip" .value) ; 

1897 nextif( semicolon, +088); enter id (lip); 

1898 end; 

1899 until not find2([ident],fsys,+08$); 

1900 end; 

1902 procedure typedefinition(fsysrsos); 

1903 var lip rip; 

1904 begin fwptr r=nil; intypedec r=true; 



1905 repeat lip:=newident(types,nil f nil,+090); 

1906 if lipOnil then 

1907 begin nextif(eqsy, +091); 

1908 lip". idtype:=typ(fsys+[semicolon, ident]); 

1909 nextif( semicolon, +092); enterid(lip); 

1910 end; 

1911 until not find2([ident],fsys,+093); 

1912 while fwptrOnil do 

1913 begin assert syOident; 

1914 id:=fwptr".name; lip :=searchid([ types]); 

1915 fwptr".idtype".eltype:=lip".idtype; fwptr:=fwptr".next 

1916 end; 

1917 intypedec:=false; 

1918 end; 



1920 procedure vardeclaration(fsys:sos); 

1921 var lip,hip,vip:ip; lsp:sp; 

1922 begin with b do begin 

1923 repeat hip:=nil; lip:=nil; 

1924 repeat vip:=newident(vars,nil,nil,+094); 

1925 if vipOnil then 

1926 begin enterid(vip); vip".iflag:=[]; 

1927 if lip=nil then hip:=vip else lip".next:=vip; lip:=vip; 

1928 end; 

1929 until endofloop( fsys+[colon1, ident.. packedsy], [ident], comma, +095); 

1930 {+096} 

1931 nextif(colon1,+097); 

1932 lsp:=typ(fsys+[semicolon,ident]); 

1933 while hipOnil do 

1934 begin hip".idtype:=lsp; 

1 935 hip". vpos. ad :=address(lc,sizeof(lsp) .false); hip :=hip". next 

1936 end; 

1937 nextif( semicolon, +098); 

1938 until not find2([ident],fsys,+099); 

1939 end end; 

1941 procedure pfhead(fsys:sos; 

1942 var fip:ip; 

1943 var again rboolean; 

1944 par am rboolean); forward; 

1946 function parlist(fsys:sos; var hlc:integer):ip; 

1947 var lastip,hip,lip,pip:ip; lsp,tsp:sp; iflagriflagset; again rboolean; 

1948 sz: integer; 

1949 begin parlist:=nil; lastip:=nil; 

1950 repeat {once for each formal-par ameter-section} 

1 951 if findl ([ident, varsy,procsy,funcsy],fsys+[semicolon], +0100) then 

1952 begin 

1953 if (syrprocsy) or (sy=funcsy) then 

1954 begin 

1955 pfhead(fsys+ [semicolon, ident, var sy,procsy,funcsy], 

1956 hip, again, true); 

1957 hip". pfpos. ad :=address(hlc,pnumsize+ptrsize, false); 

1958 hip".pfkind:=formal; lip:=hip; 

1959 top: =top". nl ink; level :=level-1 

1960 end 



1961 
1962 
1963 
1964 
1965 
1966 
1967 
1968 
1969 
1970 
1971 
1972 
1973 
1974 
1975 
1976 
1977 
1978 
1979 
1980 
1981 
1982 
1983 
1984 
1985 
1986 
1987 
1988 
1989 
1990 
1991 
1992 
1993 
1994 
1995 
1996 

1998 
1999 
2000 
2001 
2002 
2003 
2004 
2005 
2006 
2007 
2008 
2009 
2010 
2011 
2012 
2013 
2014 
2015 
2016 



begin hip:=nil; lip:=nil; iflag:=[assigned,noreg]; 
if sy=varsy then 

begin if 1 ag := [refer, assigned, used, noreg 3; insym end; 
repeat pip : =newident ( vars , nil , nil ,+0101); 
if pipOnil then 
begin enterid(pip); pip".iflag:=iflag; 

if lip=nil then hip:=pip else lip".next:=pip; 
lip:=pip; 
end; 
iflag:=iflag+[samesect]; 
until endofloop( fsys+ [semicolon, colon 1 ], 

[ident], comma, +01 02); {+0103} 
nextif(colon1,+0104); 
if refer in if lag then 

begin lsp:=vpartyp(fsys+[ semicolon]); 
sz:=ptrsize; tsp:=lsp; 
while formof(tsp,[carray]) do 

begin tsp". arpos. ad :=address(hlc,ptrsize, false); 

tsp:=tsp" .aeltype 
end; 
end 
else 

begin lsp:=typid(+0105); sz:=sizeof(lsp) end; 
pip:=hip; 
while pipOnil do 

begin pip". vpos. ad :=address(hlc,sz, false); 

pip".idtype:=lsp; pip :=pip". next 
end; 
end; 
if lastip=nil then parlist:=hip else lastip".next:=hip; 
lastip:=lip; 
end; 
until endofloop(fsys, [ident, varsy,procsy,funcsy], 
semicolon, +01 06); {+0107} 
end; 

procedure pfhead; {forward declared} 
var lip:ip; lsp:sp; lnp:np; kl:idclass; 
begin lip:=nil; again :=false; 
if sy=procsy then kl:=proc else 

begin kl:=func; fsys:=fsys+[ colon 1, ident] end; 
insym; 

if syOident then begin error (+01 08); id:=spaces end; 
if not param then lip:=searchsection(top".fname); 
if lipOnil then 

if (lip".klass<>kl) or (lip".pfkind<>forwrd) then 

errid(+0109,id) 
else 

begin b.forwcount:=b.forwcount-1 ; again:=true end; 
if again then insym else 

begin lip:=newip(kl,id,nil,nil); 

if sy=ident then begin enterid(lip); insym end; 
lastpf no : =lastpfno+1 ; lip" ,pf no : =lastpf no ; 
end; 
level := lev el+1; 



2017 new(lnp,blck); lnp". occur :=blck; lnp~.nlink:=top; top:=lnp; 

20Y8 if again then lnp*.fname:=lip~.parhead else 

2019 begin lnp".fname:=nil; 

2020 if find3(lparent,fsys,+011G) then 

2021 begin lip*.parhead:=parlist(fsys+Crparent],lip".heacllc); 

2022 nextif(rparent,+0111) 

2023 end; 

2024 end; 

2025 if (klsfunc) and not again then 

2026 begin nextif(eolon1,+0112); lsp:=typid(+0113); 

2027 if f ormof( Isp, £ power.. tag]) then 

2028 begin er ror ( +0114); isp : =nil end ; 

2029 lip" . idtype : =lsp ; 

2030 end; 

2031 fip:=lip; 

2032 end; 
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procedure pfdeelaration(fsys:sos); 
var lip:ip; again: boolean; markp:" integer; lbp:bp; 
begin with b do begin 
pfhead(fsys+£ident, semicolon, labelsy.. beg insy], lip, again, false); 
nextif (semicolon, +01 15); 

if findKCident, labelsy. .beginsy],fsys+[semicolon], +01 16) then 
if sysident then 
if id= f forward ' then 
begin insym; 
if lip".pfpos.lv>1 then genpnam(ps_fwp,lip); 
if again then err id (+01 17, lip% name) else 

begin lip~.pfkind:=forwrd; forwcount:=forwcount+1 end; 
end else 
if ids'extern » then 
begin lip".pfkind:=extrn; 

lip".pfpos.lv:sl; insym; teststandard 
end 
else errid(+0118,id) 
else 

begin lip~.pfkind:=actual; 
#ifndef STANDARD 

mark(markp); 
*endif 

if not again then if lip~.pfpos.lv>1 then genpnam(ps_fwp,lip); 

new(lbp); lbp":=b; nextbp:=lbp; 

le:=address( lip*. headlc.0, false); {align headlc} 

ilbno:=0; forweount:=0; lchain:=nil; 

if lip'.idtypeOnil then 

lip^.pfpos. ad :=address(lc,sizeof(lip A . idtype) .false); 
block( fsys+[ semicolon], lip) ; 
b:=nextbp"; 
lifndef STANDARD 

r el ease ( mar kp ) ; 
# end if 

end; 
if not main then eofexpected:=forwcount=0; 
nex ti f ( semicolon ,+0119); 
level : =level-1 ; top: =top* .nl ink ; 
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2076 procedure expression(fsys:sos); forward; 

2077 {this forward declaration cannot be avoided} 

2079 procedure selectarrayelement(fsys:sos); 

2080 var isp,lsp:sp; 

2081 begin 

2082 repeat loadaddr; isp:=nil; 

2083 if formof(a.asp,tarrays t carray]) then isp:=a.asp*.inxtype else 

2084 asperr(+0120); 

2085 lsp: =a. asp; 

2086 expression(fsys+£comma3); force(desub( isp) ,+0121 ); 

2087 {no range check} 

2088 if IspOnil then 

2089 begin a.packbit:=spack in lsp'.sflag; 

2090 descraddrdsp^.arpos); lsp:=lsp~.aeltype 

2091 end; 

2092 a.asp:=lsp; a.ak:=indexed; 

2093 until endofloop(fsys,Enotsy..lparent], comma, +0122); {+0123} 

2094 end; 



2096 procedure selector (fsys: sos; fip:ip; iflag:iflagset); 

2097 {selector computes the address of any kind of variable. 

2098 Four possibilities: 

2099 l.for direct accessable variables, 'a' contains offset and level, 

2100 2. for indirect accessable variables, the address is on the stack. 

2101 3. for array elements, the top of stack gives the index (one word). 

2102 The address of the array is beneath it. 

2103 4. for variables with address in direct accessible pointer variable, 

2104 the offset and level of the pointer is stored in 'a'. 

2105 If a.asp=nil then an error occurred else a. asp gives 

2106 the type of the variable. 

2107 } 

2108 var lip:ip; 11, 12: integer; 

2109 begin H:=lino; inita(fip A .idtype,0); 

2110 case fip'.klass of 

2111 vars: with a do 

2112 begin pos:=fip~.vpos; if refer in fip^.iflag then ak:=pfixed end; 

2113 field: 

2114 begin a:=lastnp~.wa; 

2115 fieldaddr(fip'.foffset); a.asp:=fip*.idtype 

21 1 6 end; 

2117 func: with a do 

2118 if fip'.pf kind= standard then asperr(+0124) else 

2119 begin pos:=fip".pfpos; pos.lv :=pos.lv+1; 

2120 if pos.lv>=level then if fipOcurrproc then error(+0125); 

2121 if fip'.pfkindO actual then err or (+01 26); 

2122 if sy=arrow then error (+01 27); 

2123 end 

2124 end; {case} 

2125 while find2([lbrack, period, arrow], fsys, +0128) do with a do 

2126 if sy=lbrack then 

2127 begin insym; 

2128 selectarrayelement(fsys+Crbrack,lbrack, period, arrow]); 



2129 nextif(rbrack,+0129); iflag:=lflag+[noreg3; 

2130 end else 

2131 if sy=period then 

2132 begin insyra; iflag:=iflag+[noreg]; 

2133 if syOident then error (+01 30) else 

2134 begin 

2135 if not formof( asp, [records]) then asperr(+0131 ) else 

2136 begin lip:=searchsection(asp".fstfld); 

2137 if lip=nil then begin errid(+0132,id); asp:=nil end else 

2138 begin packbit:=spack in asp". sf lag; 

2139 fieldaddr(lip A .foffset); asp:=lip".idtype 

2140 end 

2141 end; 

2142 insym 

2143 end 

2144 end 

2145 else 

2146 begin insym; iflag:=[used]; 

2147 if aspOnil then 

2148 if asp=stringptr then asperr(+0133) else 

2149 if asp~.form=pointer then 

2150 begin 

2151 if ak=fixed then ak:=pfixed else 

2152 begin load; ak:=ploaded end; 

2153 asp:=asp~.eltype 

2154 end else 

2155 if asp*.form=files then 

2156 begin 12:=lino; gen1(op_mrk f 0); exchange(H,12); loadaddr; 

2157 gensp(WDtf) ; asp :=asp".fil type; ak:=ploaded; packbit:=true: 

2158 end 

2159 else asperr(+01^4); 

2160 end; 

2161 fip'\iflag:=fip'\iflag+iflag; 

2162 end; 

2164 procedure variable(fsys:sos); 

2165 var lip: ip; 

2166 begin 

2167 if sy=ident then 

2168 begin lip:=searchid([vars, field]); insym; 

2169 selector (fsys, lip, [used, assigned ,noreg]) 

2170 end 

2171 else begin error(+0135); inita(nil,0) end; 

2172 end; 
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2176 function plistequal(p1,p2:ip):boolean; 

2177 var ok:boolean; q1,q2:sp; 

2178 begin plistequal:=eqstruct(p1'\idtype,p2 / \idtype); 

2179 p1:=pT\parhead; p2:=p2~.parhead; 

2180 while (plOnil) and (p2<>nil) do 

2181 begin ok:=false; 

2182 if pr.klass=p2".klass then 

2183 if pT\klass<>vars then ok:=plistequal(p1,p2) else 

2184 begin q1:=p1".idtype; q2:=p2".idtype; ok:=true; 
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while ok and formof(q1,[carray] ) and formof(q2,[carray]) do 
begin ok:=eqstruct(q1~.inxtype,q2'\inxtype); 

q1:*q1~.aeltype; q2:rq2~.aeltype; 
end; 
if not (eqstruct(q1,q2) and 

(p1 A . if lag*[ refer ,samesect]=p2'\iflag*[refer ,samesect] ) ) 
then ok:=false; 
end; 
if not ok then plistequal:=false; 
p1:=pT\neXt; p2:=p2~.next 
end; 
if (plOnil) or (p2<>nil) then plistequal:=false 
end; 

procedure callnonstandard(fsys:sos; moreargs :boolean; fip:ip); 
var nxt.liprip; lposrposition; 11 ,12: integer; 

lsp,oldasp:sp; 
begin with a.lpos do begin 

nxt:=fip~.parhead; lpos:=fip A .pfpos; 

if fip'.pfkindO formal then gen1(op_mrk,level-lv) else 

begin lexical(op_loi,lv,ad,ptrsize); gen0(op_mrs) end; 
while (nxtOnil) and moreargs do 
begin lsp:=nxt".idtype; 
if nxt A .klass=vars then 

if refer in nxf.iflag then {call by reference} 
begin 11: =lino; variable (fsys); loadaddr; 

if samesect in nxt'.iflag then lsp:=oldasp else 
begin oldasp:=asp; 12:=lino; 
while formof(lsp,[carray]) and 

formof ( asp, [ arrays, carr ay]) do 
if (compatdsp^.inx type, asp". inxtype) > subeq) or 

(lsp^.sflagOasp'.sflag) then asperr(+0136) else 
begin descraddr(asp",arpos); 

asp :=asp A .ael type; lsp:=lsp~.aeltype 
end; 
exchange(11,12); 
end; 
if not eqstruct(asp,lsp) then asperr(+0137); 
if packbit then asperr(+0138); 
end 
else {call by value} 

begin expression(fsys) ; force(lsp,+0139) end 
else 

if syOident then error(+0140) else 
begin lip:=searchid([nxf\klass]); insym; 

if lip".pfkind=standard then error(+0141) else 
if not plistequal(nxt.lip) then error(+0142) else 
if lip~.pfkind=formal then 
lexical(op_loi,lip". pfpos.lv, 

lip~.pfpos.ad,pnumsize+ptrsize) 
else 

begin gen1(op_lex, level-lip*. pfpos.lv); 

genpnam( op_loc ,lip) 
end 
end; 
nxt : =nxt~ .nex t ; moreargs : =f ind3 ( comma , fsys , +0 1 43 ) ; 



2241 end; 

2242 while moreargs do 

2243 begin error(+0144); expression(fsys); load; 

2244 moreargs:=find3(comma,fsys,+0145) 

2245 end; 

2246 if nxtOnil then error(+0146); 

2247 if fip'.pfkindOformal then genpnam(op_cal,fip) else 

2248 begin lexical(op_loi,lv,ad+ptrsize,pnumsize); genO(op_cas) 

2249 asp:=fip".idtype; 

2250 end end; 

2252 procedure fileaddr; 

2253 var larattr; 

2254 begin la:=a; a:=fa; loadaddr; a:=la end; 

2256 procedure callrdl ,12: integer); 

2257 var latattr; 

2258 begin with a do begin 

2259 la:=a; asp:=desub(asp); genl (op_mrk,0); fileaddr; 

2260 if asp=intptr then gensp(RDI) else 

2261 if asp=charptr then gensp(RDC) else 

2262 if asp=realptr then gensp(RDR) else 

2263 if asp=longptr then gensp(RDL) else asperr(+0147); 

2264 if aspOla.asp then checkbnds(la.asp); 

2265 a:=la; exchange(H ,12); store; 

2266 end end; 

2268 procedure call w(fsys: so s; 11 ,12 '.integer); 

2269 var m:libmnem; 

2270 begin with a do begin gent(op_mrk,0); 

2271 fileaddr; exchange(H ,12); loadcheap; asp:=desub(asp); 

2272 if string (asp) then 

2273 begin gen 1 (op_loc,asp~. size); m:=WRS end 

2274 else 

2275 begin m:=WRI; 

2276 if aspOintptr then 

2277 if asp=charptr then m:=WRC else 

2278 if asp=realptr then m:=WRR else 

2279 if asp=boolptr then m:=WRB else 

2280 if asp=stringptr then m:=WRZ else 

2281 if asp=longptr then m:=WRL else asperr(+0148); 

2282 end; 

2283 if find3(colon1,fsys,+0149) then 

2284 begin expression(fsys+[colon1 ]); 

2285 force(intptr,+0150); m:=succ(m) 

2286 end; 

2287 if find3(colon1,fsys,+0151) then 

2288 begin expression(fsys); force(intptr,+0152); 

2289 if mOWSR then error (+01 53) else m:=WRF; 

2290 end; 

2291 gensp(m); 

2292 end end; 

2294 procedure callrw(fsys:sos; lpar ,w,ln:boolean); 

2295 var 11 , 12, oldlc.errno: integer; ftype,lsp:sp; 

2296 begin with b do begin oldlc:=lc; ftype:=textptr ; 



2297 inita(textptr,argvCord(w)].ad); a.pos.lv:=0; fa:=a; 

2298 if lpar then 

2299 begin l1:=lino; 

2300 if w then expression(fsys+[colon1]) else variable(fsys); 

2301 l2:=lino; 

2302 if formof(a.asp,C files]) then 

2303 begin ftype;=a.asp; 

2304 if (a.akOfixed) and (a.akOpfixed) then 

2305 begin loadaddr; inita(nilptr .reserve(ptrsize) ); 

2306 store; a.ak:=pfixed 

2307 end; 

2308 fa:=a; {store doesn't change a} 

2309 if (syOcomma) and not In then error(+0154); 

2310 end 

231 1 else 

2312 begin if iop[w]=nil then error (+01 55); 

2313 if w then callw(fsys,H,12) else callrCH ,12) 

2314 end; 

2315 while find3(comma,fsys,+0156) do with a do 

231 6 begin H:=lino; 

2317 if w then ex pression(fsys+C colon 1 ]) else variable(fsys); 

2318 12:=lino; 

2319 if ftype=textptr then 

2320 if w then callw(fsys,H,12) else callr(H,12) 

2321 else 

2322 begin errno:=+0157; 

2323 if w then force(ftype~.filtype,errno) else 

2324 begin store; 12:=lino end; 

2325 gen1(op_mrk,0); fileaddr; gensp(WDW); 

2326 ak:=ploaded; packbit:=true; 

2327 if w then store else 

2328 begin lsp:=asp; asp :=ftype~.fil type; force(lsp,errno); 

2329 exchange(H,12) 

2330 end; 

2331 gen1(op_mrk,0); fileaddr; 

2332 if w then gensp(PUTX) else gensp(GETX) 

2333 end 

2334 end; 

2335 end 

2336 else 

2337 if not In then error(+0158) else 

2338 if iop[w]=nil then error (+01 59); 

2339 if In then 

2340 begin if ftypeOtextptr then error (+01 60); 

2341 gen1(op_mrk,0); fileaddr; 

2342 if w then gensp(WLN) else gensp(RLN) 

2343 end; 

2344 lc:=oldlc 

2345 end end; 



2347 procedure callflp(fsys:sos; lparrboolean; mrlibmnem); 

2348 begin with a do begin 

2349 . if lpar then 

2350 begin var iable(fsys); loadaddr; 

2351 if not forraof( asp, [files]) then asperr(+0l6l ) else 

2352 if (mOEFL) and (aspOtextptr) then error (+01 62); 
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end 
else 

if iop[m=PAG]=nil then error (+01 63) else 
gen1(op_lae,argv[ord(m=PAG)].ad); 
gensp(m); asp:=boolptr ; {not for PAG} 
end end; 

procedure callnd(fsys:sos; mrlibmnem); 

label 1; 

var lsp:sp; sz,int:integer; 

begin with a do begin 

if not formof( asp, [pointer]) then asperr(+0164) else 
if asp=stringptr then asperr(+0165) else 
asp : =asp" . el type ; 
while find3( comma, fsys, +01 66) do 
begin 

if aspOnil then {asp of form record or variant} 
if asp".form=records then asp:=asp".tagsp else 
if a sp".form= variant then asp:=asp".subtsp else asperr(+0167); 
if asp=nil then constant(fsys,lsp,int) else 
begin assert asp".form=tag; 

int:=cstinteger(fsys,asp".tfldsp,+0168); lsp:=asp".fstvar; 
while IspOnil do 

if lsp".varval<>int then lsp:=lsp".nxtvar else 
begin asp:=lsp; goto 1 end; 
end; 
1 : end; 
sz : =sizeof ( asp) ; int : =intsize+ptrsize ; 
if sz>int then int:=(sz+int-1 ) div int * int; 
gen1(op_loc,int); gensp(m) 
end end; 

procedure callpg(m:libmnem); 

begin gensp(m); if not formof(a.asp,[files]) then asperr(+0169) end; 

procedure callrrC mrlibmnem); 
begin 

if not formof(a.asp,[ files]) then asperr(+0170) else 
if a.asp=textptr then genl (op_loc,0) else 
gen 1 (op_loc ,sizeof ( a .asp* .f il type ) ) ; 
gensp(m); 



2396 procedure callmr(m:libmnem); 

2397 begin teststandard; gensp(m); 

2398 if not formof( a. asp, [pointer]) then asperr(+0171 ) 

2399 end; 



2401 procedure callpu(m:llbmnem; zsp,asp,isp:sp); 

2402 begin i!sp:=desub(isp); 

2403 if formof(zsp,[arrays,carray]) and formof(asp,[arrays,carray]) then 

2404 if (spack in (zsp".sflag - asp~.sflag)) and 

2405 eqstruct(zsp".aeltype, asp". ael type) and 

2406 eqstruct(desub(zsp".inxtype),isp) and 

2407 eqstruct(desub( asp". inx type ),isp) then 

2ll0 8 begin descraddr(zsp".arpos); descraddr(asp".arpos); gensp(m) end 



2409 else error(+0172) 

2410 else error (+01 73) 

241 1 end; 

2413 procedure calKfsys: sos; fip: ip); 

2414 var lkey: standpf; lparrboolean; lsp,lsp2:sp; 

2415 begin with a do begin fsys:=fsys+[ comma]; 

2416 lpar : =f ind3 ( lpar ent, fsys, +01 74); if lpar then fsys:=fsys+[rparent]; 

2417 if fip".pfkind<>standard then callnonstandard( fsys, lpar ,fip) else 

2418 begin lkey :=fip" .key; 

2419 if lkey in [pput ..phalt.feof ..fabs.f round, .farctan] then 

2420 gen1(op_mrk,0); 

2421 if lkey in [pput ..prelease, fabs.. farctan] then 

2422 begin if not lpar then error (+01 75); 

2423 if lkey <= prelease then 

2424 begin variable(fsys) ; loadaddr end 

2425 else 

2426 begin expression(fsys); force( fip". id type ,+0176) end; 

2427 end; 

2428 case lkey of 

2429 pread,preadln,pwrite,pwriteln: {0, 1,2,3 resp} 

2430 callrw( fsys ,lpar ,lkey>=pwrite ,odd( ord( lkey) ) ) ; 

2431 pput : 

2432 callpg(PUTX); 

2433 pget: 

2434 callpg(GETX); 

2435 ppage: 

2436 callflp( fsys, lpar, PAG); 

2437 preset: 

2438 callrr(OPN); 

2439 prewrite: 

2440 callrr(CRE); 

2441 pnew: 

2442 callnd(fsys,NEWX); 

2443 pdispose: 

2444 callnd(fsys.DIS); 

2445 ppack: 

2446 begin lsp:=asp; nextif( comma -0177); expression(fsys) ; load; 

2447 lsp2:=asp; nextif ( comma ,+f . 8); var iable( fsys) ; loadaddr; 

2448 callpu(PAC,asp,lSD.- .-?) 

2449 end; 

2450 pun pack: 

2451 begin lsp:=asp; nexv-if, comma, +0179); variable(fsys) ; loadaddr; 

2452 lsp2:=asp; nextif (comma, +01 80); expression (fsys); load; 

2453 callpu(UNP,lsp,lsp2,asp) 

2454 end; 

2455 pmark: 

2456 callmr(SAV); 

2457 prelease: 

2458 callmr(RST); 

2459 phalt: 

2460 begin teststandard; 

2461 if not lpar then genl (op_loc-,0) else 

2462 begin expression (fsys); forcedntptr ,+0181 ) end; 

2463 gensp(HLT); 

2464 end; 
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feof: 

cal 1 f 1 p( f sys , 1 par , EFL ) ; 
feoln: 

callflp(fsys,lpar,ELK); 
fabs: 
begin asp:=desub(asp); 

if asp=intptr then gensp(ABI) else 
if aspsrealptr then gensp(ABR) else 
if aspslongptr then genspCABL) else asperr(+0182); 
end; 
f sqr : 

begin asp : =desub ( asp ) ; 
if aspsintptr then 

begin gen 1(op_dup,int size); gen0(op_mul) end else 
if asp= real ptr then 
begin g en 1 ( op_dup , r e al si ze ) ; 

gen0(op_fmu); fltused:=true 
end 
else if asp=longptr then 

begin gen1(op_dup,longsize); genO(op_drau) end 
else asperr(+0183); 
end; 
ford : 

begin if not nicescalar(desub(asp)) then asperr(+0184); 

asp:=intptr 
end; 
f chr : 

checkbndsC charptr ) ; 
fpred,fsucc: 

begin asp:=desub(asp); gen1(op_loc,1); 

if lkey=fpred then gen0(op__sub) else gen0(op_add); 
if nicesc alar (asp) then genrck(asp) else asperr(+0185) 
end; 
f odd i 

begin gen1(op_loc,1); gen 1(op_and,int size); asp:=boolptr end; 
f trunc : 

begin if aspOrealptr then asperr(+0186); opconvert(ri) end; 
f round : 

begin if aspOrealptr then asperr(+0187); 

gensp(RND); asp:=intptr 
end; 
fsin: 

gensp(SIN); 
fcos: 

gensp(COS); 
fexp: 

gensp(EXPX); 
fsqrt: 

gensp(SQT); 
fin: 

gensp(LOG); 
f arctan : 
gensp(ATN); 
end; 
end; 
if Ipar then nextif(rparent f +0188); 



2521 



2523 

2525 
2526 
2527 
2528 
2529 
2530 
2531 
2532 
2533 
2534 
2535 
2536 
2537 
2538 
2539 
2540 
2541 
2542 
2543 
2544 
2545 
2546 
2547 
2548 
2549 
2550 

2552 
2553 
2554 
2555 
2556 
2557 
2558 
2559 
2560 
2561 
2562 

2564 
2565 
2566 
2567 
2568 
2569 
2570 
2571 
2572 
2573 
2574 
2575 
2576 



{= 



= } 



procedure convert(fsp:sp; 11: integer); 

{Convert tries to make the operands of some operator of the same type. 

The operand types are given by fsp and a. asp. The resulting type 

is put in a. asp. 

11 gives the lino of the first instruction of the right operand. 
} 
var 12: integer; 

ts:twostruct; 
begin with a do begin asp:=desub(asp); 

ts: scorn patCfsp.asp); 

case ts of 
eq.subeq: 

rl,li,ri: 

opconvert(compat(asp,fsp)); { ri->ir etc.} 
lr.il, ir: 

begin 12:=lino; opconvert(ts); exchange(H ,12) end; 
se: 

expandemptysetC fsp) ; 
es: 

begin 12:=lino; expandemptysetC asp); exchangeCH ,12) end; 
noteq: 

asperr(+0189); 
end; 

if asp=realptr then fltused:=true 
end end; 

procedure build set ( fsys :sos) ; 

{This is a bad construct in pascal. Two objections: 

- expr..expr very difficult to implement on most machines 

- this construct makes it hard to implement sets of different size 
} 

const ncsw =16; {tunable} 
type word set = set of 0. .wbml ; 
var i, j ,val1,val2,ncst ,11 , 12, sz: integer ; 

est 1 , cst2, est 12, varpart :boolean ; 

cstpart:array[1 . .ncsw] of wordset; 

lsp:sp; 

procedure genwordset(s:wordset); 

{level 2: « buildset} 
var b,i,w: integer; 
begin 

if s=[] then w:=0 else 
if s=Cwbm1] then w:=-t15m1-1 else 
begin w:=-1; b:=t14; 

for i:=wbm1-1 down to do 

begin if i in s then w:=w+b; b:=b div 2 end; 
if wbml in s then w:=w-t15m1 else w:=w+1 
end; 
gen1(op_loc,w) 
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procedure setexpr(fsys:sos; var ctboolean; var vrinteger); 

{level 2: « buildset} 
{update lsp and sz variables of buildset and set c and v parameters} 
var min, max: integer; errnorinteger; 
begin with a do begin c:=false; v:=0; 
expression(fsys); asp:=desub(asp); 
if aspOnil then 
begin 

if lsp=nil then 
begin errno:=0; 

if not bound s ( asp ,m in, max) then 

if asp=intptr then max:=iopt-1 else errno:=+0190; 
if max>(maxsetsize-1 )*bytebits + (bytebits-1) then 

errno:=+0191; 
if errnoOO then begin asperr(errno); maxrsO end; 
sz:=even(max div bytebits +1); lsp:=asp; 
end 
else {aspOnil and IspOnil} 

if aspOlsp then asperr(+0192); 
if ak=cst then 

if pos.ad<ncsw*wordbits then 
begin c:=true; v:=pos.ad end; 



if not 
end end; 



c then load 



2604 begin with a do begin {buildset} 

2605 varpart := false; ncst:=0; sz:=max set size; lsp:=nil; 

2606 for i:=1 to ncsw do cstpart[i]:=[]; 

2607 if find2([notsy..lparent],fsys,+0193) then 

2608 repeat 1 1 : =lino ; 

2609 setexpr(fsys+[colon2, comma], cstl, vail ); cst12:=cst1; 

2610 if find3(colon2,fsys+[comma,notsy..lparent],+0194) then 

2611 begin setexpr(fsys+[comma,notsy. .Iparent],cst2,val2); 

2612 cst12:=cst12 and cst2; 

2613 if cst2 and not cstl then load; 

2614 if cstl and not cst2 then 

2615 begin 12: =lino; gen1(op_loc,val1 ); exchange(H ,12) end; 

2616 if not est 12 then 

2617 begin 12:=lino; gen1(op_mrk,0); exchange (11 ,12); 

2618 gen1(op_loc,sz); gensp(BTS) 

2619 end; 

2620 end 

2621 else 

2622 if cst12 then val2:=va!1 else gen1(op_set,sz); 

2623 if est 12 then 

2624 if (valKO) or (val2>=ncsw*wordbits) then error (+01 95) else 

2625 for i:sval1 to val2 do 

2626 begin j:=i div wordbits + 1; nest :=ncst+1 ; 

2627 cstpartE j]:=cstparttj] + [i nod wordbits] 

2628 end 

2629 else 

2630 if varpart then gen1(op_ior,sz) else varpart:=true; 

2631 until endofloop(fsys,[notsy..lparent], comma, +0196); {+0197} 

2632 ak reloaded; 



2633 if (ncst=0) and not varpart then 

2634 begin asp:=emptyset; gen1(op_loc,0) end 

2635 else 

2636 begin asp :=newsp( power ,sz); asp".elset:=lsp; 

2637 if ncst>0 then 

2638 for i:=1 to sz div word size do genwordset(cstpart[i]); 

2639 if varpart and (ncst>0) then genKop ior,sz); 

2640 end 

2641 end end; 

2643 procedure factor(fsys: sos); 

2644 var lip:ip; 11 .irinteger ; lsp:sp; 

2645 begin with a do begin 

2646 asp:=nil; paekbit:=false; ak:=loaded; 

2647 if find1([notsy..nilcst,lparent],fsys,+0198) then 

2648 case sy of 

2649 ident: 

2650 begin 1 ip :=sear chid (Ckonst, var s, field, func.carrbnd]); insym; 

2651 case lip'.klass of 

2652 func: {call moves result to top stack} 

2653 begin call(fsys,lip); ak:=loaded; packbit:=false end; 

2654 konst : 

2655 begin asp:=lip~.idtype; 

2656 if nic esc alar (asp) then {including asp=nil} 

2657 begin ak:=cst; pos. ad :=lip A . value end 

2658 else 

2659 begin ak:=ploaded; 

2660 H:=lino; gend(op_lae, abs( lip". value) ); 

2661 if asp~.form= scalar then 

2662 begin load; if lip A .value<0 then negate(H) end 

2663 else 

2664 if asp=stringptr then ak:=loaded 

2665 end 

2666 end; 

2667 field, var s; 

2668 sel ec tor (fsys, lip, [used]); 

2669 carrbnd : 

2670 begin lsp:=lip".idtype; assert formof(lsp,[carray] ); 

2671 descraddrdsp'.arpos); lsp :=lsp~.inx type; 

2672 asp:=desub(lsp); 

2673 if lip".next=nil then ak:=ploaded {low bound} else 

2674 begin genl (op_loi,2*intsize); gen0(op_add) end; 

2675 load; checkbnds(lsp); 

2676 end; 

2677 end {case} 

2678 end; 

2679 intcst: 

26 80 begin asp:=intptr; ak:=cst; pos.ad:=val; insym end; 

2681 realcst: 

2682 begin asp:=realptr ; ak:=ploaded; gend(op_lae,val); insym end; 

2683 longest : 

2684 begin asp:=longptr ; ak:=ploaded; gend(op_lae,val); insym end; 

2685 charcst : 

2686 begin asp:=charptr ; ak:=cst; pos.ad:=val; insym end; 

2687 str ingest: 

2688 begin asp:=stringstruet; gend(op_lae,val); insym; 



26 89 if aspOstringptr then ak:=ploaded; 

2690 end; 

2691 nilcst: 

2692 begin insym; asp:=nilptr; 

2693 for i:=1 to ptrsize div word size do gen Hop loc.O); 

2694 end; 

2695 lparent: 

2696 begin insym; 

2697 expression(fsys+[rparent]); nextif(rparent,+0199) 

2698 end; 

2699 notsy: 

2700 begin insym; factor(fsys); load; gen0(op_teq); 

2701 if aspOboolptr then asperr(+0200) 

2702 end; 

2703 lbrack: 

2704 begin insym; buildset(fsys+[rbrack]); nextif(rbrack,+0201 ) end; 

2705 end 

2706 end end; 

,2708 procedure term(fsys:sos); 

2709 var lsy:symbol; lsp:sp; 10,11 ,12: integer; first rboolean; 

2710 begin with a,b do begin first :=true; H:=lino; 10: =11; 

2711 f actor (fsys+[starsy..andsy]); 

2712 while find2([ star sy..andsy],fsys, +0202) do 

2713 begin if first then begin load; first :=false end; 

2714 lsy:=sy; insym; H:=lino; lsp:=asp; 

2715 factor(fsys+[starsy..andsy]); load; convert(lsp,H ); 

2716 if aspOnil then 

2717 case lsy of 

2718 starsy: 

2719 if asp=intptr then gen0(op_mul) else 

2720 if asp=realptr then gen0(op_fmu) else 

2721 if asp=longptr then gen0(op_dmu) else 

2722 if asp~.form=power then setop(op_and) else asperr(+0203); 

2723 slashsy: 

2724 if asp=realptr then gen0(op_fdv) else 

2725 if (asp=intptr) or (asp=longptr) then 

2726 begin lsp:=asp; 

2727 convert(realptr,H ); {make real of right operand} 

2728 convert(lsp,H ); {make real of left operand} 

2729 gen0(op_fdv) 

2730 end 

2731 else asperr(+0204); 

2732 divsy: 

2733 if asp=intptr then gen0(op_div) else 

2734 if asp=longptr then gen0(op_ddv) else asperr(+0205); 

2735 modsy: 

2736 begin 12:=lino; gen 1 ( op_mrk , ) ; exchange(10,12); 

2737 if asp=intptr then gensp(MDI) else 

2738 if asp=longptr then gensp(MDL) else asperr(+0206); 

2739 end; 

2740 andsy: 

2741 if asp=boolptr then setop(op_and) else asperr(+0207); 

2742 end {case} 

2743 end {while} 

2744 end end; 



2746 procedure simpleexpression(fsys:sos) ; 

2747 var lsy:symbol; lsp:sp; I1:integer; signed ,min,first:boolean; 

2748 begin with a do begin H:=lino; first:=true; 

2749 signed :=(sy= pi ussy) or (sy=minsy); 

2750 if signed then begin min:=sy=minsy; insym end else min:=false; 

2751 termCfsys + [minsy.plussy.orsy] ); lsp:=desub(asp) ; 

2752 if signed then 

2753 if (IspOintptr) and (IspOrealptr) and (IspOlongptr) then 

2754 asperr(+0208) 

2755 else if min then 

2756 begin load; first :=false; asp:=lsp; negate (11) end; 

2757 while find2([plussy,minsy,orsy],fsys,+0209) do 

2758 begin if first then begin load; first :=false end; 

2759 lsy:=sy; insym; H:=lino; lsp:=asp; 

2760 term(fsys+[minsy,plussy,orsy]); load; convert(lsp,H ); 

2761 if aspOnil then 

2762 case lsy of 

2763 plussy: 

2764 if asp=intptr then gen0(op_add) else 

2765 if asp=realptr then gen0(op_fad) else 

2766 if asp=longptr then gen0(op_dad) else 

2767 if asp".form=power then setop(op_ior) else asperr(+0210); 

2768 minsy: 

2769 if asp=intptr then gen0(op_sub) else 

2770 if asp=realptr then gen0(op_fsb) else. 

2771 if asp=longptr then gen0(op_dsb) else 

2772 if asp".form=power then 

2773 begin setop(op_com); setop(op_and) end 

2774 else asperr(+021 1 ); 

2775 orsy: 

2776 if asp=boolptr then setop(op_ior) else asperr(+0212); 

2777 end {case} 

2778 end {while} 

2779 end end; 



2781 procedure expression; { fsys:sos } 

2782 var lsy: symbol; lsp:sp; 11 ,12,13, sz:integer; 

2783 begin with a do begin H:=lino; 

2784 simpleexpression(fsys+[eqsy. .insy]); 

2785 if find2([eqsy..insy],fsys,+0213) then 

2786 begin lsy:=sy; insym; lsp:=asp; loadcheap; 12:=lino; 

2787 simpleexpression(fsys); loadcheap; 

2788 if lsy=insy then 

2789 begin 

2790 if not formofC asp, [power]) then asperr(+0214) else 

2791 if asp=emptyset then setop(op_and) else 

2792 {this effectively replaces the word on top of the 

2793 stack by the result of the 'in' operator: false } 

2794 if not (compat(lsp,asp /v .elset) <= subeq) then 

2795 asperr(+0215) 

2796 else 

2797 begin exchangeC 11, 12); setop(op_inn) end 

2798 end 

2799 else 

2800 begin convert(lsp,12); 



2801 if aspOnil then 

2802 case asp". form of 

2803 scalar: 

2804 if asp=realptr then gen0(op_cmf) else 

2805 if asp=longptr then gen0(op_cmd) else gen0(op_cmi); 

2806 pointer : 

2807 if (lsy=eqsy) or (lsy=nesy) then gen0(op_cmp) else 

2808 asperrC+0216); 

2809 power : 

2810 case lsy of 

2811 eqsy.nesy: setop(op_cmu); 

2812 ltsy,gtsy: asperr(+0217); 

2813 lesy: {'a<=b' equivalent to 'a-b=[]'} 

2814 begin setop(op_com); setop(op_and) ; 

2815 gen1(op_loc,0); expand emptysetC asp) ; 

2816 setop(op emu); lsy:=eqsy 

2817 end; 

2818 gesy: {'a>=b' equivalent to 'asb+a*} 

2819 begin sz:=even( si zeof( asp)); genl (op_dup,2*sz); 

2820 gen1(op_beg,-sz) ; setop(op_ior); 

2821 setop(op_cmu); lsy:=eqsy 

2822 end 

2823 end; {case} 

2824 arrays: 

2825 if string(asp) then 

2826 begin 13: =lino; gen1(op_mrk,0); exchange(H ,13); 

2827 gen 1(op_loc, asp". size); gensp(BCP) 

2828 end 

2829 else asperr(+0218); 

2830 records: asperr(+0219); 

2831 files: asperr(+0220) 

2832 end; { case } 

2833 case lsy of 

2834 ltsy: gen0(op_tlt); 

2835 lesy: gen0(op_tle); 

2836 gtsy: gen0(op_tgt); 

2837 gesy: gen0(op_tge) ; 

2838 nesy: gen0(op_tne); 

2839 eqs/: gen0(op_teq) 

2840 end 

2841 end; 

2842 asp:=boolptr; ak:=loaded 

2843 end; 

2844 end end; 
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procedure statement(fsys:sos); forward; 

{this forward declaration can be avoided} 



2851 procedure assignment(fsys:sos; fio:ip); 

2852 var la:attr; 11 ,12: integer ; 

2853 begin 

2854 H:=lino; selector (fsys+[becomes],fip, [assigned]); 12 

2855 la:=a; nex tif( becomes, +0221 ); 

2856 expression(fsys); loadcheap; checkasp(la.asp,+0222); 
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exchange(H,12); a:=la; 

if not formofC la. asp, [arrays.. records]) then store else 
begin loadaddr; 

if la.asp".form<>carray then 

gen1(op_blm,even(sizeof(la.asp))) 
else 

begin gen 1(op_mrk,0); descraddr(la.asp".arpos); gensp(ASZ); 
gen0(op_bls) 



end; 



end; 
end; 

procedure gotostatement ; 

{jumps into structured statements can give strange results. } 

label 1; 

var llp:lp; lbp:bp; diff :integer ; 

begin 

if syOintcst then error(+0223) else 
begin llp:=searchlab(b.lchain,val) ; 
if llpOnil then 

if lip". seen then genl (op_brb, lip". labname) 
else gen 1 (op_brf, lip". labname) 
else 

begin lbp:=b.nextbp; diff:=1; 
while lbpOnil do 

begin llp:=searchlab(lbp".lchain,val); 
if llpOnil then goto 1; 
lbp:=lbp".nextbp; diff :=diff+1 ; 
end; 
1: if llp=nil then errint(+0224,val) else 

begin 

if llp".labdlb=0 then 

begin dlbno:=dlbno+1 ; llp".labdlb:=dlbno; 

gend(ps_fwa,dlbno); {forward data reference} 
end; 
gen1(op_mrk,diff); gend(op_lae,llp".labdlb); gensp(GTO); 
end; 
end; 
insym; 
end 
end; 

procedure com pound statement(fsys: so s; err: integer); 
begin 

repeat statement (fsys+[ semicolon] ) 

until endofloop(fsys,[beginsy. .casesy] .semicolon, err) 
end; 



2905 procedure ifstatement(fsys:sos); 

2906 var lb1 ,lb2: integer; 

2907 begin with b do begin 

2908 expression(fsys+[thensy,elsesy]); 

2909 force(boolptr,+0225); ilbno:=ilbno+1; lb1:=ilbno; gen1(op_zeq,lb1 ); 

2910 nex tif(thensy, +0226); statement(fsys+[elsesy]); 

2911 if find3(elsesy,fsys,+0227) then 

2912 begin ilbno:=ilbno+1 ; lb2:=ilbno; genl (op_brf ,lb2); 



2913 genilb(lbl); statement(fsys); genilb(lb2) 

291 4 end 

2915 else genilb(lbl); 

2916 end end; 

2918 procedure casestatement(fsys:sos); 

2919 label 1; 

2920 type cip^caseinfo; 

2921 case in fo= record 

2922 next: cip; 

2923 csstart: integer; 

2924 cslab: integer 

2925 end; 

2926 var lsprsp; head,p,q,r :cip; 

2927 10 , 11 , 12 , i ,n ,m ,min ,max rinteger ; 

2928 begin with b do begin 

2929 expressionC fsys+[ofsy, semicolon, ident..plussy] ); lsp:=a.asp; load; 

2930 if not nicescalar(desubClsp)) then begin error (+0228); lsp:=nil end; 

2931 ilbno:=ilbno+1; 10:=ilbno; gen1(op_brf ,10); {jump to CSA/B} 

2932 ilbno:=ilbno+1; H:=ilbno; 

2933 nextif(ofsy,+0229); head:=nil; max:=minint; rain:=maxint; n:=0; 

2934 repeat ilbno:=ilbno+1 ; 12:riibno; {label of current case} 

2935 repeat i :=cst integer (fsys+[ comma, colon 1, semicolon], lsp, +0230); 

2936 if i>max then max:=i; if i<min then min:=i; n:=n+1; 

2937 q:=head; r:=nil; new(p); 

2938 while qOnil do 

2939 begin {chain all cases in ascending order} 

2940 if q A .cslab>=i then 

2941 begin if q".cslab=i then error(+0231 ); goto 1 end; 

2942 r: = q; q:=q~.next 

2943 end; 

2944 1: p".next:=q; p~.cslab:=i; p". csstart: =12; 

2945 if r=nil then head:=p else r".next:=p; 

2946 until endofloop(fsys+C colon 1, semicolon], 

2947 [ident..plussy], comma, +0232); {+0233} 

2948 nextif(colont,+0234); genilb(12); 

2949 gen1(op_brf,H); 

2950 until lastsemicolon(fsys,Cident..plussy],+0235); 

2951 assert n<>0; 

2952 dlbno:=dlbno+1; gendlb(dlbno); genpria 

2953 if (max div 3) - (min div 3) < n then 

2954 begin gencst(min); gene st( max -min ) ; 

2955 ra:=op_csa; 

2956 while headOnil do 

2957 begin 

2958 while head A .cslab>min do 

2959 begin gencst(-1); min:=min+1 end; 

2960 genclb(head A . csstart); min:=min+1; head :=head A . next 

2961 , end; 

2962 end 

2963 else 

2964 begin gencst(n); m:=op_csb; 

2965 while headOnil do 

2966 begin gencst (head". cslab); 

2967 genclb(head". csstart); head ^head". next 

2968 end; 



statement^ fsys+[ semicolon] ) ; 
{+0236 +0237} 
m(ps_rom,currproc); gencst(-1); 



2969 
2970 
2971 

2973 
2974 
2975 
2976 
2977 
2978 
2979 
2980 
2981 
2982 

2984 
2985 
2986 
2987 
2988 
2989 
2990 
2991 
2992 

2994 
2995 
2996 
2997 
2998 
2999 
3000 
3001 
3002 
3003 
3004 
3005 
3006 
3007 
3008 
3009 
3010 
3011 
3012 
3013 
3014 
3015 
3016 
3017 
3018 
3019 
3020 
3021 
3022 
3023 
3024 



end; 

genend; genilb(lO); gend(op_lae,dlbno); genO(rn); genilb(H) 
end end; 

procedure repeatstatement( fsys :sos) ; 
var lb1: integer; 
begin with b do begin 

ilbno:=ilbno+1; lb1:=ilbno; genilb(lbl); 
compoundstatement(fsys+[untilsy],+0238); {+0239} 
nextif(untilsy,+0240); genlin; 
expression(fsys); force(boolptr ,+0241 ); 
ilbno:=ilbno+1; gen0(op_teq); gen1(op_zeq,ilbno); 
gen 1 ( op_brb , lb 1 ) ; gen ilb ( il bno ) 
end end; 

procedure whilestatement(fsys :sos) ; 
var Ib1,lb2: integer; 
begin with b do begin 

ilbno:=ilbno+2; lb1 : =ilbno-1 ; genilb(lbl); lb2:=ilbno; 
genlin; expression(fsys+Cdosy]); 
force( boolptr , +0242 ) ; gen 1 (op_zeq ,lb2 ) ; 
nextif(dosy,+0243); statement ( fsys ) ; 
gen 1 (op_brb ,lb1 ) ; genilb( lb2 ) 
end end; 

procedure forstatement(fsys:sos); 

{the upper bound is evaluated once and stored in a temporary local} 

var lip:ip; dsp,lsp:sp; tosym, est 1,cst2, local :boolean; 

val1,val2,endlab,looplab,oldlc,llc,lad:integer; 
begin with a.b do begin 

lsp:=nil; lad:=0; tosym :=true; local :=level<>1 ; oldlc:=lc; 
ilbno:=ilbno+1; looplab:=ilbno; ilbno:=ilbno+1; endlab:=ilbno; 
if syOident then error(+0244) else 
begin lip:=searchid([vars]); insym; 
lsp : =lip A .idtype ; lad : =lip~ . vpos .ad ; 
if local and 

((lad<currproc".headlc) or (lip'.vpos.lvOlevel)) then 
err or (+0245) 
else lip".iflag:slip".iflag+[used,assigned]; 
end; 
if not nicescalar(desubdsp)) then begin error(+0246); lsp:=nil end; 
nextif( becomes, +0247); dsp:=desub(lsp); assert sizeof(dsp)=wordsize; 
expression(fsys+[tosy,downtosy,notsy..lparent,dosyl); 
cst1:=ak=cst; if cstl then vail :=pos.ad; force(dsp,+0248); 
if not cstl then gen1(op_dup,intsize); 
if findl (Ctosy,downtosy],fsys+Cnotsy,.lparent,dosy],+0249) then 

begin tosym :=sy=tosy; insym end; 
expression(fsys+[dosy]); 

cst2:=ak=cst; if cst2 then val2:=pos.ad; force(dsp,+0250); 
if not est 2 then 

begin llc:=reserve(intsize); 

genl (op_dup,intsize) ; genl (op_stl ,11c) ; 
end; 
if est 1 then 
begin 

if tosym then gen1(op_bgt,endlab) else gen1(op_blt,endlab); 



3025 gen 1 ( op_loc , val 1 ) 

3026 end 

3027 else 

3028 begin ilbno;=ilbno+1 ; 

3029 if tosyra then genl (op_ble,ilbno) else gen1(op_bge,ilbno); 

3030 gen1(op_beg, -intsize); gen 1(op_brf .endlab); genilb(ilbno) 

3031 end; 

3032 assert eqstruct(a.asp,dsp); 

3033 checkbnds(lsp); pop( local , lad, intsize); genilb(looplab); 

3034 nextif(dosy,+025D; statement (fsys); 

3035 push( local, lad, intsize); 

3036 if cst2 then gen1(op_loc,val2) else genl (op_lol,llc); 

3037 gen 1(op_beq, endlab); push (local, lad, intsize); gen1(op_loc,1); 

3038 if tosym then gen0(op_add) else gen0(op_sub); 

3039 a.asp:=dsp; checkbnds(lsp); pop( local, lad, intsize); 

3040 gen1(op_brb,looplab); genilbC endlab); 

3041 lc:=oldlc 

3042 end end; 



3044 
3045 
3046 
3047 
3048 
3049 
3050 
3051 
3052 
3053 
3054 
3055 
3056 
3057 
3058 
3059 
3060 
3061 

3063 
3064 
3065 
3066 
3067 
3068 
3069 
3070 
3071 



procedure withstatementC fsys :sos) ; 
var lnp,oldtop:np; oldlc : integer ; pbitrboolean; 
begin with b do begin 
oldlc :=lc; oldtop:=top; 
repeat variable(fsys+[comma,dosy] ); 

if not formofCa.asp.C records]) then asperr(+0252) else 
begin pbit:=spack in a. asp". sf lag; 

new(lnp,wrec); lnp". occur :=wrec; lnp".fname:=a.asp".fstfld; 
if a.akOfixed then 

begin loadaddr; inita(nilptr ,reserve(ptrsize)); store; 

a.ak:=pfixed; 
end; 
a.packbit:=pbit; lnp~.wa:=a; lnp~.nl ink :=top; top:=lnp; 
end; 
until endofloop(fsys+[dosy],Cident],comma,+0253); {+0254} 
nextif(dosy,+0255); statement (fsys); 
top:=oldtop; lc:=oldlc; 
end end; 

procedure assertion(fsys:sos); 
begin test standard; 
if opt['a'3=off then 

while not (sy in fsys) do insym 
else 

begin gen1(op_mrk,0); expression(fsys); force(boolptr ,+0256); 
gen1(op_loc,e.orig); gensp(ASS); 



end 



end; 



3073 procedure statement; {fsys: sos} 

3074 var lip:ip; llprlp; lsy:symbol; 

3075 begin 

3076 assert [labelsy. .casesy.endsy] <= fsys; 

3077 assert [ident,intcst] * fsys = []; 

3078 if f i nd2 ( [ in tc st 1 , f s ys+ C id en t ] , +02 57 ) then 

3079 begin llp:=searchlab(b.lchain,val); 

3080 if llprnil then errint(+0258,val) else 



3081 
3082 
3083 
3084 
3085 
3086 
3087 
3088 
3089 
3090 
3091 
3092 
3093 
3094 
3095 
3096 
3097 
3098 
3099 
3100 
3101 
3102 
3103 
3104 
3105 
3106 
3107 
3108 
3109 
3110 
3111 
3112 
3113 
3114 
3115 
3116 
3117 
3118 
3119 
3120 

3122 



begin if lip". seen then errint(+0259,val) else lip". seen :=true; 

gen ilb( lip* .lab name) 
end; 
insym; nextif (colon 1, +0260); 
end; 
if f ind2([ident,beginsy..casesy], fsys, +0261 ) then 
begin if giveline then if syOwhilesy then genlin; 
if sy=ident then 

if id=' assert ' then 

begin insym; assertion(fsys) end 
else 

begin lipr=searchid([vars,field,func,proc]); insym; 
if lip".klass=proc then call( fsys, lip) 
else assignment (fsys, lip) 
end 
else 

begin lsy:=sy; insym; 
case lsy of 
beginsy: 

begin compound statement (fsys, +02 62); {+0263} 

nextif ( end sy, +0264) 
end; 
gotosy: 

goto statement ; 
ifsyr 

ifstatement(fsys) ; 
casesy: 

begin casestatement( fsys); nextif (endsy, +0265) end; 
whilesy: 

whilestatement(fsys); 
repeatsy: 

repeatstatement(fsys) ; 
forsy: 

for statement ( fsys ) ; 
withsy: 

wi thstatement ( fsys ) ; 
end 
end; 



end 



end; 

{=== 



= } 



3124 procedure body( fsys :sos; fip:ip); 

3125 var i,sz,letdlb,namdlb,inidlb:integer; llprlp; 

3126 begin with b do begin namdlb:=0; 

3127 {produce PRO} 

3128 genpnam(ps_pro,fip); gencst(fip*.headlc); 

3129 gencst(ord(fip*.pfpos.lv<=1)); 

3130 {initialize files} 

3131 if level=1 then {body for main} 

3132 begin dlbno:=dlbno+1 ; inidlb:=dlbno; gend(ps_fwa,inidlb); 

3133 gen1(op_mrk,0); gend(op_lae,dlbno) ; genl (op_lae,0); gensp(INI); 

3134 end; 

3135 trace( 'procentr' ,fip,namdlb); 

3136 dlbno;=dlbno+1; letdlb:=dlbno; 



3137 gend(ps_fwc,letdlb); gend(op_beg,letdlb); 

3138 {the body itself} 

3139 lcmax:=lc; currproc:=fip; 

3140 compoundstatement(fsys,+0266); {+0267} 

3141 lcmax :=address( lcmax, 0, false); {align lcmax} 

3142 traceCprocexit' ,fip,namdlb); 

3143 {undefined or global labels} 

3144 llp:=lchain; 

3145 while llpOnil do 

3146 begin if not lip". seen then errint(+0268,llp".labval); 

3147 if llp'.labdlbOO then 

3148 begin gendlb(llp~.labdlb); genpnam(ps_rom,fip); 

3149 genclbdlp^.labname); gencst( lcmax); genend; 

3150 {this doesn't work if local generators are around} 

3151 end; 

3152 lip: =llp". nex tip 

3153 end; 

3154 {define BUG size} 

3155 gend(ps_let,letdlb); gencstdcmax-fip'.headlc); 

3156 {finish and close files} 

3157 tr eewalk( top". f name); 

3158 if level=1 then 

3159 begin gendlb(inidlb); gen1(ps_con,argc+1 ); 

3160 for i:=0 to argc do with argvCi] do 

31 61 begin gencst(ad); 

3162 if (ad=-1) and (i>1) then errid(+0269,name) 

3163 end; 

3164 genend; gen1(op_mrk,0); genl (op_loc,0); gensp(HLT) 

3165 end 

3166 else 

3167 begin 

3168 if fip".klass<>func then sz:=0 else 

3169 begin 

3170 if not (assigned in fip~.iflag) then 

3171 err id(-(+0270),fip". name); 

3172 sz:=even(sizeof(fip".idtype)); push(local,fip"\pfpos.ad,sz); 

3173 end; 

3174 gen1(op_ret,sz); gen0(ps_end); 

3175 end 

3176 end end; 



3178 



{= 



= } 



3180 procedure block; {forward declared} 

31 81 var ad: integer; 

3182 begin with b do begin 

3183 assert Clabelsy..withsy] <= fsys; 

3184 assert [ident.intcst ,casesy,endsy .period] * fsys = []; 

3185 if f ind3( label sy, fsys, +0271) then labeldeclaration(fsys); 

3186 if f ind3 ( const sy, fsys, +02 72) then constdefinition(fsys); 

3187 if find3(typesy, fsys, +0273) then typed efinition( fsys); 

3188 if find3(varsy,fsys,+0274) then vardeclaration(fsys); 

3189 if fip=progp then 

3190 begin 

3191 if iop[ true ]<> nil then 

3192 begin ad :=address(lc,fhsize+buff size .false); 



3193 argv[1].ad:=ad; iop[true]".vpos.ad:=ad 

3194 end; 

3195 if iop[false]Onil then 

3196 begin ad :=address(lc,fhsize+buffsize, false); 

3197 argv[0].ad:=ad; iop[false]~.vpos.ad:=ad 

3198 end; 

3199 if address(lc,0,false)<>0 then genl (ps_hol,lc); {align lc} 

3200 lc:=progp".headlc; level :=1 

3201 end; {externals are also extern for the main body} 

3202 while find2(Cprocsy,funcsy], fsys, +0275) do pf declaration (fsys) ; 

3203 if forwcountOO then error (+0276); {forw proc not specified} 

3204 nextif(beginsy,+0277); 

3205 body( fsys+Ccasesy ,endsy] , f ip) ; 

3206 nextif( end sy, +0278); 

3207 end end; 

3209 



{= 



3211 procedure programme(fsys:sos); 

3212 var stdin,stdout:boolean; p:ip; 

3213 begin 

3214 nextif(progsy,+0279); nextif(ident,+0280); 
.3215 if find3(lparent,fsys+Csemicolon],+0281) then 

3216 begin 

3217 repeat 

3218 if syOident then error (+0282) else 

3219 begin stdin:=id='input »; stdout :=id=' out put '; 

3220 if stdin or stdout then 

3221 begin p:=newip(vars,id,textptr ,nil); 

3222 enter id (p); iopC stdout ]:=p; 

3223 end 

3224 else 

3225 if argc<maxargc then 

3226 begin argc:=argc+1 ; 

3227 argvC argc]. name :=id; argv[argc].ad:=-1 

3228 end; 

3229 insym 

3230 end 

3231 until endofloop(fsys+Crparent, semicolon], 

3232 [ident], comma, +0283); {+0284} 

3233 if argc>maxargc then 

3234 begin error(+0285); argc:=maxargc end; 

3235 nextif(rparent,+0286); 

3236 end; 

3237 nextif(semicolon,+0287); 

3238 block(fsys.progp); 

3239 if optC'l'JOoff then 

3240 begin gen 1 (ps_mes,meslino); gencst(e.orig); genend end; 

3241 eofexpected:=true; nextif( period, +02 88); 

3242 end; 



3244 procedure compile; 

3245 var lsys:sos; 

3246 begin lsys:=[progsy,labelsy. .withsy]; 

3247 repeat eofexpected:=false; 

3248 main:=find2([progsy,labelsy,beginsy. . withsy], lsys, +0289); 



3249 
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3254 
3255 
3256 
3257 
3258 
3259 
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3264 
3265 
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3271 
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3277 
3278 
3279 
3280 



if main then programme(lsys) else with b do 
begin 

if find3 ( const sy,lsys ,+0290) then constdefinition(lsys); 
if find3(typesy,lsys,+029D then typedefinition(lsys); 
if find3(varsy,lsys,+0292) then vardeclaration(lsys); 
gen 1(ps_hol, address (lc,0, false)); lc:=0; level :=1; 
while find2([procsy,funcsy],lsys,+0293) do pfdeclaration(lsys); 
end; 
error(+0294); 
until false; { the only way out is the halt in nextln on eof } 



begin {main body of pcompiler} 
rewrite (errors); 
initl; init2; init3; init4; 

{all this initializing must be independent of opts} 
reset(eml); if not eof(eral) then opt ions( false); 
rewrite(em1 ); write(em1 ,MAGICLOW,MAGICHIGH); 
#ifdef GETREQUIRED 

get (input); 
#endif 

if eof (input) then gen0(ps_eof) else 
begin nextch; insym; 

handleopts; {initialize all opt dependent stuff} 
compile 
end; 
//ifdef STANDARD 
9999: ; 
tfendif 
end. {pcompiler} 



/* collection of options, selected by including or excluding 'defines' */ 



9 

10 

11 

13 
14 
15 

17 
18 
19 
20 
21 

23 
24 



/* select only one of the following: 

# define V7 1 
/* # define V6 1 
/* # define VPLUS 1 

/* select only one of the following: 

# define C7 1 
/« # define C6 1 
/* # define NC6 1 

# ifdef BOOT 

# define INTJDNLY 1 
#endif 



*/ 



tfifndef BOOT 

# define 
/« # define 

# define 
#endif 



HARDWARE_FP 

INTJDNLY 

SFLOAT 



/* Unix version 7 */ 
/* Unix version 6 */ 
/« Unix version 6 plus diff listing */ 



/* version 7 C-compiler */ 
/* version 6 C-compiler */ 
/* something between C6 and C7 */ 



/* if you've hardware floating point */ 
/* for interpreted programs only */ 
/* for single precision floats */ 



/* Version number of the EM1 object code */ 

# define VERSION 2 /* 16 bits number */ 




1 


#define 


sp_fsnieBi 1 


2 


#define 


spjramem 149 


3 


#define 


sp_fpseu 150 


4 


#define 


sp npseu 30 


5 


#define 


sp_filbG 180 


6 


#define 


sp_nilbQ 60 


7 


#define 


sp festO 


8 


^define 


sp nestO 240 


9 


^define 


sp ilbl 


I 240 


10 


#define 


sp_ilb2 241 


11 


#define 


sp dlbl 


I 242 


12 


#define 


sp_dlb2 243 


13 


f define 


sp_dnam 244 


14 


#define 


sp_pnam 245 


15 


fdefine 


sp_seon 246 


16 


#define 


sp_re6n 247 


17 


#define 


sp_cst 1 


I 248 


18 


#define 


sp_estm 249 


19 


#define 


sp_est2 250 


20 


#define 


spJLcon 251 


21 


#define 


sp_cenc 


i 255 


23 


#d€flne 


ps_bss 


150 


24 


#define 


ps__oon 


151 


25 


#define 


ps_end 


152 


26 


#define 


ps_eof 


153 


27 


#define 


ps__exe 


154 


28 


#define 


ps_exd 


155 


29 


#d«fin« 


ps_fwa 


156 


30 


#de Ine 


ps__fwe 


157 


31 


#def ine 


ps_fwp 


158 


32 


#define 


ps_hol 


159 


33 


#define 


ps_ima 


160 


34 


#define 


ps_imc 


161 


35 


#define 


ps_let 


162 


36 


#define 


ps_mes 


163 


37 


^define 


ps_pro 


164 


38 


^define 


ps_rom 


165 


39 


#define 


sp_lps€ 


ju 165 


41 


#define 


op_aar 


1 


42 


^define 


op_aas 


2 


43 


#define 


op_add 


3 


44 


#define 


op_adi 


4 


45 


fdefine 


op_and 


5 


46 


^define 


op_ans 


6 


47 


#define 


op_beg 7 


48 


#define 


op_beq 


8 


49 


#define 


op_bes 


9 


50 


#define 


op_bge 


10 


51 


^define 


op_bgt 


11 


52 


#define 


op_ble 


12 


53 


#define 


op_blm 


13 


54 


#define 


op_bls 


14 


55 


#define 


op_blt 


15 


56 


#define 


op_bne 


16 



57 

58 

59 

60 

61 

62 

63 

64 

65 

66 

67 

68 

69 

70 

71 

72 

73 

74 

75 

76 

77 

78 

79 

80 

81 

82 

83 

84 

85 

86 

87 

88 

89 

90 

91 

92 

93 

94 

95 

96 

97 

98 

99 

100 

101 

102 

103 

104 

105 

106 

107 

108 

109 

110 

111 

112 



^define op_ 
//define op" 
#define op_ 
#define op_ 
#define op" 
#define op 
#define op_ 
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brb 17 
"brf 18 
]cal 19 
"cas 20 
"cdi 21 
cdf 22 
"cfd 23 
"cfi 24 
"cid 25 
"cif 26 
"and 27 
"cmf 28 
]omi 29 
]cmp 30 
]cms 31 
]cmu 32 
com 33 
cos 34 
]csa 35 
csb 36 
"dad 37 
"ddv 38 
"dec 39 
"dee 40 
"del 41 
"div 42 
"dmd 43 
"dmu 44 
"dsb 45 
"dup 46 
"dus 47 
"exg 48 
"fad 49 
"fdv 50 
"fef 51 
"fif 52 
"frau 53 
"fsb 54 
]hlt 55 
inc 56 
"ine 57 
inl 58 
]inn 59 
ins 60 
ior 61 
"ios 62 
"lab 63 
"lae 64 
"lai 65 
"lal 66 
"lar 67 
"las 68 
"lde 69 
"ldf 70 
"idl 71 
"lex 72 
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op_lin 73 
op_lnc 74 
op_lni 75 
op_loc 76 
op_loe 77 
op_lof 78 
op_loi 79 
op_lol 80 
op_lop 81 
op_lor 82 
op_los 83 
op__lsa 84 
op_mod 85 
op_mon 86 
opjnrk 87 
opjnrs 88 
opjmrx 89 
opjnul 90 
op_mxs 91 
op_neg 92 
op__nop 93 
op_nul 94 
op_pad 95 
op_psb 96 
op_rck 97 
op_rcs 98 
op_res 99 
op_ret 100 
op_rol 101 
op_ror 102 
op_rtt 103 
op_sai 104 
op_sar 105 
op_sas 1 06 
op_sde 107 
op_sdf 108 
op_sdl 109 
op_ses 110 
op_set 111 
op_shl 112 
op_shr 113 
op_sig 1 1 4 
op_ste 115 
op_stf 116 
op_sti 117 
op_stl 118 
op_stp 119 
op_str 120 
op_sts 121 
op_sub 122 
op_teq 123 
op_tge 124 
op_tgt 125 
op_tle 126 
op_tlt 127 
op_tne 128 
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op_trp 129 
op_xor 130 
op_xos 131 
op_zeq 132 
op_zge 133 
op_zgt 134 
op_zle 135 
op_zlt 136 
op_zne 137 
op_zre 138 
op_zrl 139 
sp_lmnem 139 
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non-standard feature used 

identifier *%s' declared twice 

end of file encountered 

bad line directive 

unsigned real: digit of fraction expected 

unsigned real: digit of exponent expected 

unsigned real: too many digits (>72) 

unsigned integer: too many digits (>72) 

unsigned integer: overflow 032767) 

string constant: must not exceed one line 

string constant: at least one character expected 

string constant: double quotes not allowed (see c option) 

string constant: too long (>72 chars) 

comment: ';' seen (statements skipped?) 

bad character 

identifier ! $s' not declared 

location counter overflow: arrays too big 

arraysize too big 

variable ! %s' never used 

variable '£s' never assigned 

the files contained in '%s' are not closed automatically 

constant expected 

constant: only integers and reals may be signed 

constant: out of bounds 

simple type expected 

enumerated type: element identifier expected 

enumerated type: ',' or ')' expected 

enumerated type: ',' expected 

enumerated type: ')' expected 

subrange type: type must be scalar, but not real 

subrange type: '..' expected 

subrange type: type of lower and upper bound incompatible 

subrange type: lower bound exceeds upper bound 

array type: '[' expected 

conformant array: low bound identifier expected 

conformant array: '..' expected 

conformant array: high bound identifier expected 

conformant array: ':' expected 

conformant array: index type identifier expected 

array type: index type not bounded 

array type: index separator or ']' expected 

array type: index separator expected 

array type: ']' expected 

array type: 'of expected 

record variant part: tag type identifier expected 

record variant part: tag type identifier expected 

record variant part: type must be bounded 

record variant part: 'of expected 

record variant: type of case label and tag incompatible 

record variant: multiple defined case label 

record variant: ',' or ':' expected 

record variant: ',' expected 

record variant: ':' expected 

record variant: '(' expected 

record variant: ')' expected 

or end of variant list expected 



record variant part: 



57 record variant part: ';' expected 

58 record variant part: end of variant list expected 

59 record variant part: there must be a variant for each tag value 

60 field list: record section expected 

61 record section: field identifier expected -o 

62 record section: ',' or ':' expected ^ 

63 record section: ',' expected Q 

64 record section: ':' expected r~ 

65 field list: ';' or end of record section list expected z 

66 field list: ';' expected rn 

67 field list: end of record section list expected oo 

68 type expected 

69 type: simple and pointer type may not be packed ;** 

70 pointer type: type identifier expected ro 

71 pointer type: type identifier expected ^ 

72 record type: 'end' expected 

73 set type: 'of expected ^ 

74 set of integer: the i option dictates the number of bits (default 16) ^ 

75 set type: base type not bounded 

76 set type: too many elements in set (see i option) 

77 file type: 'of expected 

78 file type: files within files not allowed 

79 var parameter: type identifier or conformant array expected 

80 var parameter: type identifier expected 

81 label declaration: unsigned integer expected 

82 label declaration: label '%i' multiple declared cr> 

83 label declaration: ',' or ';' expected r 1 " 1 

84 label declaration: ',' expected —i 

85 label declaration: ';' expected 3 

86 const declaration: constant identifier expected cc 

87 const declaration: '=' expected to 

88 const declaration: ';' expected * 

89 const declaration: constant identifier or 'type 1 , 'var', 'procedure', 'function' or •— ' 

90 type declaration: type identifier expected 00 

91 type declaration: '=' expected H 

92 type declaration: ';' expected 

93 type declaration: type identifier or 'var', 'procedure', 'function' or 'begin' expect 

94 var declaration: var identifier expected 

95 var declaration: ',' or ':' expected 

96 var declaration: ',' expected 

97 var declaration: ':' expected 

98 var declaration: ';' expected 

99 var declaration: var identifier or 'procedure', 'function' or 'begin' expected 

100 parameter list: 'var' , 'procedure' ,' function' or identifier expected 

101 parameter list: parameter identifier expected 

102 parameter list: ',' or ':' expected 

103 parameter list: ',' expected 

104 parameter list: ':' expected 

105 parameter list: type identifier expected > 

106 parameter list: ';' or ')' expected f£ 

107 parameter list: ';' expected 

108 proc/func declaration: proc/func identifier expected un 

109 proc/func declaration: previous declaration of '%s' was not forward 

110 proc/func declaration: parameter list expected 

111 parameterlist : ')' expected 

112 func declaration: ':' expected 



113 func declaration: result type identifier expected 

114 func declaration: result type must be scalar, subrange or pointer 

115 proc/func declaration: ';' expected 

116 proc/func declaration: block or directive expected 

117 proc/func declaration: *%s' again forward declared 

118 proc/func declaration: *%s' unknown directive 

119 proc/func declaration: '; * expected 

120 indexed variable: '[' only allowed following array variables 

121 indexed variable: index type not compatible with declaration 

122 indexed variable: ',' or ']♦ expected 

123 indexed variable: ',' expected 

124 assignment: standard function not allowed as destination 

125 assignment: cannot store the function result 

126 assignment: formal parameter function not allowed as destination 

127 assignment: function identifier may not be de-referenced 

128 variable: '[', '.', »"» or end of variable expected 

129 indexed variable: ']' expected 

130 field designator: field identifier expected 

131 field designator: '. f only allowed following record variables 

132 field designator: no field '56s 1 in this record 

133 referenced variable: '"* not allowed following zero-terminated strings 

134 referenced variable: , ~* only allowed following pointer or file variables 

135 variable: var or field identifier expected 

136 call: array parameter not conformable 

137 call: type of actual and formal variable parameter not similar 

138 call: packed elements not allowed as variable parameter 

139 call: type of actual and formal value parameter not compatible 

140 call: proc/func identifier expected 

141 call: standard proc/func may not be used as parameter 

142 call: parameter lists of actual and formal proc/func incompatible 

143 call: »,» or »)' expected 

144 call: too many actual parameters supplied 

145 call: , )» expected 

146 call: too few actual parameters supplied 

147 read (In): type must be integer, char or real 

148 write(ln): type must be integer, char, real, string or boolean 

149 write(ln): ':', »,» or »)» expected 

150 write(ln): field width must be integer 

151 write(ln): ':', V or ')* expected 

152 write (In): precision must be integer 

153 write(ln): precision may only be specified for reals 

154 read/write: too few actual parameters supplied 

155 read/write: standard input /out put not mentioned in program heading 

156 read/write: ',' or ')' expected 

157 read/write: type of parameter not the same as that of the file elements 

158 read/write: parameter list expected 

159 readln/writeln: standard input/output not mentioned in program heading 

160 readln/writeln: only allowed on text files 

161 eof/eoln/page: file variable expected 

162 eoln/page: text file variable expected 

163 eof/eoln/page: standard input/output not mentioned in program heading 

164 new/dispose: pointer variable expected 

165 new/dispose: C-type strings not allowed here 

166 new/dispose: ',' or ')' expected 

167 new/dispose: too many actual parameters supplied 

168 new/dispose: type of tagfield value is incompatible with declaration 
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put/get: file variable expected 

reset/rewrite: file variable expected 

mark/ release: pointer variable expected 

pack/unpack: array types are incompatible 

pack/ unpack: only for arrays 

call: '('or end of call expected 

standard proc/func: parameter list expected 

standard proc/func: parameter type incompatible with specification 

pack: ' , ' expected 

pack: ',' expected 

unpack: ',' expected 

unpack: ',' expected 

halt: integer expected 

abs: integer or real expected 

sqr: integer or real expected 

ord: type must be scalar or subrange, but not real 

pred/succ: type must be scalar or subrange, but not real 

trunc: real argument required 

round : real argument required 

call: ')• expected 

expression: left and right operand are incompatible 

set: base type must be bounded or of type integer 

base type upper bound exceeds maximum set element number (255) 

incompatible elements 

']' or element list expected 

'..', ' ,' or ']' expected 

elements do not fit (see i option) 

',' or ']' expected 

1 , ' expected 
factor expected 
factor: •)' expected 
factor: type of factor must be boolean 
set: ']' expected 

term: multiplying operator or end of term expected 
term: '*' only defined for integers, reals and sets 
term: V only defined for integers and reals 
term: f div f only defined for integers 
term: •mod' only defined for integers 
term: 'and' only defined for booleans 

simple expression: only integers and reals may be signed 
simple expression: adding operator or end of simple expression expected 
simple expression: '+' only defined for integers, reals and sets 
simple expression: '-' only defined for integers, reals and sets 
simple expression: 'or' only defined for booleans 
expression: relational operator or end of expression expected 
expression: set expected 

expression: left operand of 'in' not compatible with base type of right operand 
expression: only ' = ' and '<>' allowed on pointers 
expression: '<• and •>' not allowed on sets 
expression: comparison of arrays only allowed for strings 
expression: comparison of records not allowed 
expression: comparison of files not allowed 
assignment: ':=* expected 

assignment: left and right hand side incompatible 
goto statement: unsigned integer expected 
goto statement: label '?i' not declared 



set: 
set: 
set: 
set: 
set: 
set: 
set: 
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if statement: type of expression must be boolean 

if statement: 'then' expected 

if statement: 'else' or end of if statement expected 

case statement: type must be scalar or subrange, but not real 

case statement: 'of 1 expected 

case statement: incompatible case label 

case statement: multiple defined case label 



case statement: 
case statement: 
case statement: 
case statement: 
case statement: 
case statement: 
repeat statement: 
repeat statement: 



expected 
, ' expected 
: ' expected 
;' or 'end 1 expected 
; ' expected 
end' expected 

or 'until' expected 

expected 



repeat statement: 'until' expected 

repeat statement: type of expression must be boolean 

while statement: type of expression must be boolean 

while statement: 'do' expected 

for statement: control variable expected 

for statement: control variable must be local 

for statement: type must be scalar or subrange, but not real 

for statement: ': = ' expected 

for statement: type of initial value and control variable incompatible 

for statement: 'to' or 'down to' expected 

for statement: type of final value and control variable incompatible 

for statement: 'do' expected 

with statement: record variable expected 

with statement: ',' or 'do' expected 

with statement: ',' expected 

with statement: 'do' expected 

assertion: type of expression must be boolean 

statement expected 

label *%i' not declared 

label '%i' multiple defined 

statement: ':' expected 

unlabeled statement expected 

compound statement: ';' or 'end' expected 

compound statement: ';• expected 

compound statement: 'end' expected 

case statement: 'end' expected 

body: ';• or 'end' expected 

body: '; ' expected 

body: label 'fci' declared, but never defined 

program parameter '%s' not declared 

function '%s' never assigned 

block: declaration or body expected 

block: 'const', 'type', 'var', 'procedure', 'function' or 'begin' expected 

block: 'type', 'var', 'procedure', 'function' or 'begin' expected 

block: 'var', 'procedure', 'function' or 'begin' expected 

block: 'procedure', 'function' or 'begin* expected 

block: unsatisfied forward proc/func declaration(s) 

block: 'begin' expected 

block: 'end' expected 

program heading: 'program' expected 

program heading: program identifier expects 



281 program heading: file identifier list expected 

282 program heading: file identifier expected 

283 program heading: ',' or •)' expected 

284 program heading: ',* expected 

285 program heading: maximum number of file arguments exceeded (12) 

286 program heading: ')' expected 

287 program heading: •;' expected 

288 program: '.' expected 

289 'program' expected 

290 module: 'const', 'type', 'var', 'procedure* or 'function' expected 

291 module: 'type', 'var', 'procedure' or 'function' expected 

292 module: 'var', 'procedure' or 'function' expected 

293 module: 'procedure' or 'function' expected 

294 garbage at end of program 




OPTIONS - RETURN CCfTROL STATEMENT OPTION SETTIKG. 
COPYRIGHT ICi UNIVERSITY OF MINNESOTA ■- 1978. 
A. B. MICKEL. 77/11 6/92. 

THE ORIGINAL ROUTINE -OPTION- ACCEPTED A CNE-CHAFACTER 
OPTION NAME AND RETURNED AN OPTION SETTING OF ♦ , -, *, 
OR A POSITIVE INTEGER. 

THIS VERSION, CALLED -OPTIONS-* ACCEPTS ANY STRING 
OF i TO 18 ALPHANUMERIC CHARACTERS I STARTING WITH AN 
ALPHA} AS THE OPTION NAME ANO RETURNS A STRING OF 
1 TO 10 CHARACTERS OR A POSITIVE INTEGER AS THE OPTION 
SETTING. AN EQUALS SIGN HAY 8E USED BETWEEN AN 
OPTION KANE AND ITS OPTION SETTING. IF THERE IS NO 
OPTION SETTING AFTER THE EQUALS SIGN, THEN THE 
EQUALS SIGN ITSELF IS USEO AS THE OPTION SETTING. IF 
THE OPTION NAME IS FOLLOWED 8Y A COMMA, PERIOD, OR 
RIGHT PARENTHESIS, THE OPTIC* SETTING IS RETURNED AS A 
STRING OF 10 BLANK CHARACTERS. 



2 * 

3 * 

4 * 
§ * 

6 * 

7 * 

8 * 

9 * 

10 * 

11 * 

12 * 

13 ♦ 

14 * 

15 * 

16 * 

17 * 

18 * 

19 * 

20 * 

21 ♦ 

22 * 

23 * 
2 i» * 

25 * 

26 * 

27 * 

28 ■» 

29 * 

30 * 

31 *) 
32 

33 FUNCTION GPUCNSINAHEI ALFA; VAR Si SETTING! I BOOLEAN* 
34 

35 CONST 

36 CSAOORESS = 70B l*CONTRQL STATEMENT ADDRESS*) 3 
37 

^d TYPE 



THE INPUT VARIABLE -NAME- 
RECORD TYPE -SETTING*, 
ALFA. 



IS NOW TYPE ALFA, AND IN THE 
THE FIELD -CNCFF- IS NCM TYPE 



SEE T«E PASCLIB WRITEUP FOR EXTERNAL DOCUMENTATION. 
NOTE THAT THE NAME OF THIS VERSION IS -OPTIONS-. 
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csimagep s record case boolean of 
false i <*! integer)? 
true i ip* -lqwccrei 
end; 

lowcqre = packed arrayti. .801 of char; 
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bQ 

41 

42 

43 

44 

45 VAR 

46 

47 

48 

49 

50 

51 

52 

53 BEGIN t*OPTIONS*) 

54 

55 

56 



CSIMAGEl CSIMAGEP? 
OPNAME 1 ALFA I 
11 INTEGER 
J I INTEGER 
Kl INTEGER 
FOUNOt boolean; 



I* IfcDEX IN OS IMAGE *)? 
(* INDEX FOR OPNAME *)? 
<* IhOEX FOR S.ONCFF *) i 



FOUND 1= false; 

S. SNITCH 1= FALSE? S.SIZE 1-0? 

csimage.a i= csadoress; 

57 I 1= 1 C*SKIP PROGRAM NAME ANO PARAMETERS.*)? 

58 WHILE CSIMAGE.P^CIJ IN t*A*..*Z*, ♦0*..*9*, * *1 DO 

59 I I* I * 1? 

60 IF NOT fCSIfcAGE.P^CIJ IN t*)*» *.*1) THEN 

61 I 1* X ♦' 1 (*SKIP SLASH IF FIRST DELIMITER.*)? 

62 WHILE NOT tCSlMAGE.P^t I J IN (♦/♦, ♦!♦, *.*!) DO 



I I* I ♦ i! 

IF CSINAGE.P^CIJ = ♦/♦ THEN l*CRACK OPTIONS.*) 
REPEAT 

I l* I ♦ i; 

j i= i; 

OPNAME ts ♦ ♦? 

IF CSIMAGE.P-CI1 IN t+At..*Z*l THEN BEGIN 

WHILE ICSIMAGE.P^CIl IN C*At.«+Z+, *0+.«*9*l ) AND NOT FCUNO 

DO BEGIN 

OPNAME CJ1 1= CSINAGE.P^CIl? 

J is J f i? 

I is I ♦ il 

IF <NAME = OPNAME) ANO NOT CCSIMAGE.P-tll IN t*At. .♦Z*1* 
THEN BEGIN 
FOUND Is TRUE? 
IF ICSIMAGE.P-tll = *-*) AND 

NOT CCSIMAGE.P^CI+IJ IN C*, ♦,♦*♦,♦) *1 ) THEN 

n=i» i; 

S. SWITCH 1= NOT (CSIfAGE.P^CIl IN t*0*. .*9*1)? 
IF S. SWITCH TI-EN BEGIN 
S.ONGFF I* * *? 

K 1= 1? 

WHILE NOT CCSIHAGE.P^tll IN t*, ♦,*.♦,♦) *1) DO BEGIN 
S.ONGFFCK1 1= CSIMAGE.P^CU? 
K 1= K ♦ i; 
I l« I ♦ « 
ENDS 
END 
ELSE 

WHILE CSIMAGE.P"'tI1 IN tt0*..*9*l DO BEGIN 
S.SIZE 1= S.SIZE*10 

♦ COROICSIMAGE.F-CII) - ORDt*0*))? 
I is I ♦ 1? 

eno; 

END? 

end; 

END? 
IF NOT FOUND THEN 

WHILE NOT ICSIMAGE.P-tll IN t ♦,*,♦.♦,*) tl) 00 I i« I ♦ 11 
UNTIL CCSIHAGE.P^m IN £t. ♦,♦)♦!) OR FOUND? 
OPTIONS, is found; 
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TREEPRINT - A Package to Print Trees 
on any Character Printer 

Ned Freed 
Kevin Carosso 

Mathematics Department 

Harvey Mudd College 

Claremont, Calif. 91711 



One of the problems facing a programmer who deals with complex 
linked data structures in Pascal is the inability to display such a 
structure in a graphical form. Usually it is too much to ask a 
system debugging tool to even understand records and pointers, let 
alone display a structure using them in the way it would appear in a 
good textbook. Likewise very few operating systems have a package 
of routines to display structures automatically. Pascal has a 
tremendous advantage over many languages in its ability to support 
definable types and structures. If the environment is incapable of 
dealing with these features, they become far less useful. 

This lack became apparent to us in the process of writing an 
algebraic expression parser which produced internal N-ary trees. 
There was no way at the time under our operating system debugger 
{VAX/VMS) to get at the data structure we were generating. When the 
routines produced an incorrect tree we had no way of finding the 
specific error * 

Our frustration led to the development of TREEPRINT. Starting 
with the algorithm of Jean Vaucher [1], we designed a 
general-purpose tool capable of displaying any N-ary tree on any 
character output device. The trees are displayed in a pleasant 
visual form and in the manner in which they would appear if drawn by 
hand. We feel that TREEPRINT is of general use — hence its 
presentation here. 

The structure of TREEPRINT is that of an independent collection 
of subroutines that any program can call. Unfortunately standard 
Pascal does not support this form, while our Pascal environment 
does. However, building TREEPRINT directly into a program should 
present no difficulty. 

TREEPRINT requires no knowledge of the format of the data 
structure it is printing. It has even been used to print a tabular 
linked structure within a FORTRAN program! In order to allow this, 
two procedures are passed in the call to TREEPRINT. One is used to 
"walk" the tree, the other to print identifying labels for a given 
node. Other parameters are values such as the size of the nodes, 
the width of the page, etc. One of the advantages of this calling 
mechanism is that a single version of TREEPRINT can be used to 
display wildly different structures, even when they are within the 
same program. 



One of the major features of TREEPRINT is its ability to span 

pages. A tree that is too wide to fit on one page is printed out in -o 

"stripes" which are taped together edge-to-edge after printing. In g 

addition trees may optionally be printed either upside-down or o 

reversed from left-to-right. r- 

The method used by TREEPRINT is detailed in Vaucher's work [1]. m 

In its current implementation additional support for N-ary ^ 
structures has been added, as well as full connecting-arc printing 

and the reversal features. Basically, TREEPRINT walks the input g 

tree and constructs an analogous structure of its own which ^ 

indicates the positions of every node. The new structure is linked ^ 
along the left edge and across the page from lef t-to-right . Once 

this structure is completed, TREEPRINT walks the new structures and ^ 

prints it out in order. Once printout is finished, the generated v* 
structure is DISPOSE'd of. 

There are only two minor problems in TREEPRINT currently. The 
first is that a structure which contains circular loops will hang 
the routine. This could be detected in the POSITION phase of 
TREEPRINT by checking each new node against all of its ancestors. 
However, if used in a non-Pascal application, this might fail due to 
problems in comparing pointers. If this check is necessary we ^ 
suggest it be implemented in the LOWERNODE procedure passed to m 
TREEPRINT. This procedure at least understands the type of pointer -h 
it is dealing with. 3 

DO 

The second problem is a feature of the POSITION routine which 3 
centers a node above its sons. This tends to make the trees 

generated wider than necessary. This is largely a matter of taste g 

— some minor changes would remove this. oo 

The listing of TREEPRINT which follows should serve to document 
the method of calling the routine. The functions of the 
user-supplied procedures are also detailed. 
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module TREEPRINT (input, output) ; 

<* 

TREEPRINT - A routine to print N-ary trees on any character 
printer. This routine takes as input an arbitrary N-ary tree, 
some interface routines, and assorted printer parameters and 
writes a pictorial representation of that tree to a file. The 
tree is nicely formatted and is divided into vertical stripes 
that can be taped together after printing. Options exist to 
print the tree backwards or upside down if desired. 

The algorithm for TREEPRINT originally appeared in "Pretty- 
Printing of Trees", by Jean G. Vaucher, Software-Practice and 
Experience, Vol. 10, 553-561 (1980). The algorithm used here 
has been modified to support N-ary tree structures and to have 
more sophisticated printer format control. Aside from a common 
method of constructing an ancillary data structure and some 
variable names, they are now very dissimiliar. 

TREEPRINT was written by Ned Freed and Kevin Carosso, 
5-Feb-81. It may be freely distributed, copied and modified 
provided that this note and the above reference are included. 
TREEPRINT may not be distributed for any fee other than cost 
of duplication. 

INPUT - The call to TREEPRINT is: 

TREEPRINT (TREE,TREEFILE,PAGESIZE, VERTKEYLENGTH, 
HORIKEYLENGTH, PRINTKEY, LOWERNODE) 

where the parameters are: 

TREE - The root of the tree to be printed. The nodes of 
the tree are of arbitrary type, as TREEPRINT 
does not read them itself but calls procedure 
LOWERNODE to do so. In a modular enviroment 
this should present no problems. If TREEPRINT 
is to be installed directly in a program TREE 
will have to be changed to agree in type with 
the actual tree's nodes. 

TREEFILE - A file variable of type text. The tree is 
written into this file. 

PAGESIZE - The size of the page on output represented 

as an integer count of the number of available 
columns. The maximum page size is 512. Any size 
greater than 512 will be changed to 512. 

LOWERNODE - A user procedure TREEPRINT calls to walk 
the user's tree. The format for the call is 
described below along with the functions 
LOWERNODE must perform. 

PRINTKEY - A user procedure TREEPRINT calls to print 

out a single line of a keyword description of 
some node in the user's tree. The description 
may be multi-line and of any width. The call 
format is described below. 

VERTKEYLENGTH - The number of lines of a description 
printed by PRINTKEY. This must be a constant 
over all nodes. If VERTKEYLENGTH is negative, 
its absolute value is used as the key length and 
the whole tree is inverted on the vertical axis. 
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HORIKEYLENGTH - The number of characters in a single 

line of a description printed by PRINTKEY. This 
must be a constant. If negative the absolute 
value of HORIKEYLENGTH is used and the whole 
tree is inverted from left to right. 

CALLS TO USER PROCEDURES - The calls to user-supplied procedures 
have the following format and function: 

PRINTKEY (LINENUMBER,LINELENGTH,NODE) 

LINENUMBER - The line of the node description to print. 
This varies from 1 to VERTKEYLENGTH. Since TREEPRINT 
operates on a line-at-a-time basis, PRINTKEY must be 
able to break up the output in a similiar fashion. 

LINELENGTH - The length of the line. PRINTKEY must 

output this many characters to TREEFILE - no more, no 
less. 

NODE - The node of the user's tree to derive information 
from. 

LOWERNODE (NODE, SONNUMBER) 

SONNUMBER - The sub-node to return. A general N-ary tree 
will have N of them. 

NODE - The node of the user's tree to derive the 
information from. 

LOWERNODE, on return should equal NIL if that node does 
not exist, NODE if the SONNUMBER is illegal, and 
otherwise a valid sub-node. Note that circular 
structures will hang treeprint thoroughly. The condition 
that LOWERNODE returns NODE when N is exceeded must be 
strictly adhered to, as TREEPRINT uses this to know 
where to stop. LOWERNODE is used to hide the interface 
between TREEPRINT and the user's tree so that no format 
details of the tree need be resident in TREEPRINT. 



OUTPUT - All output is directed to TREEFILE. 
conditions or messages. 



There are no error 2° 



*) 

(* The declaration of the user's node type. If type checking is a 
problem this should be changed to match the type for the actual 
nodes in a tree. *) 



type 



nodeptr 



"integer; 



procedure treeprint (tree : nodeptr; var treefile : text; 

pagesize, vertkeylength, horikeylength 
integer; procedure printkey; function 
lowernode : nodeptr) ; 



type 



reflink - ~link; 

link = record 

next : 
pnode 
pos : 
lstem 



reflink; 
: nodeptr; 
integer; 
boolean; 



ustem : boolean; 
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end; 

refhead = "head; 

head = record 

next : 
first 
end; 



refhead; 
: reflink; 



maxposition, minposition, width, w, charp : integer; 

startposition, beginposition, endposition : integer; 

pagewidth, p, i, j , stemlength, vertnodelength : integer; 

endloop : boolean; 

line : packed array [1..512] of char; 

L, oldL : reflink; 

lines, slines, H, D : refhead; 

procedure cout (c : char) ; 

(* Cout places a character in the line buffer at the 
current character position. The pointer charp is 
incremented by this action to reflect the change. *) 

begin (* Cout *) 

charp := charp + 1; 

line[charp] := c; 
end; (* Cout *) 

procedure cdump; 

(* Cdump dumps all characters that have accumulated in 
the line buffer. No characters are omitted and no 
cr-lf is appended. *) 

begin (* Cdump *) 

if charp > then for charp := 1 to charp do 
write (treef ile, line [charp] ) ; 

charp := 0; 
end; (* Cdump *) 

procedure ctrim; 

(* Ctrim dumps all characters that have accumulated in 
the line buffer with trailing spaces removed. A 
WRITELN is used to end the line. *) 

begin (* Ctrim *) 

while (charp > 0) and (line[charp] = ' • ) do 

charp := charp - 1; 
if charp > then for charp := 1 to charp do 

write (treef ile, line[charp] ) ; 
charp := 0; 
writeln (treefile) ; 
end; (* Ctrim *) 

function position (N : nodeptr; var H : refhead; pos : integer) 
: reflink; 

(* Position is a recursive function that positions all the 
nodes of the tree on the print page. In doing so, it 
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constructs an auxiliary data structure that is connected 
by line number along the edge and position from left to 
right. In addition, it stores some of the original tree 
connections for arc printing. *) 



over, lastover, nodecount 
Nlower : nodeptr; 
L, left, right : reflink; 
needright : boolean; 



integer; 



*) 



L; 
= 0; 



begin (* Position *) 

if N = nil then (* Be defensive about illegal nodes 
position := nil 
else 

begin (* Create a new node in our tree. *) 
new (L) ; 
position := L; 
L'.pnode := N; 
L~.ustem := false; 
if H = nil then 

begin (* A new line has been reached. *) 
new (H); 
IT. next := nil; 
L^.next := nil; 
end 
else 

begin (* Shift position if conflicting. *) 
L~.next := H*. first; 
if H~. first". pos < pos + 2 then 
pos := H~.f irst" .pos - 2; 
end; 

IT. first : 

nodecount 

over := 1; 

repeat (* Count the number of lower nodes. *)* 
Nlower := lowernode (N,over) ; 
if ((Nlower <> N) and (Nlower <> nil)) then 

nodecoun- := nodecount +1; 
over := ov-;-r + 1; 
until Nlower = N; 
if nodecount > then 

begin (* There are lower nodes, loop to position 
L'.lstem := true; 
lastover := nodecount - 1; 
nodecount := over; 
over := - lastover; 
needright := true; 

repeat (* Recursively evaluate lower positions. * 
repeat (* Find one that is non-nil. *) 
if nodecount > then 

Nlower := lowernode (N, nodecount) 
else 

Nlower := N; 
nodecount := nodecount - 1; 
until Nlower <> nil; 
if Nlower ON then 
begin 

left := 

position (Nlower, H 



*) 



.next, pos + over) i 



pos 



lines := nil; 
minposition := 
maxposition := 
charp := 0? 



0; 
0; 



240 if needright then 

241 begin 

242 right • = left; 

243 needright *= false; 

244 end 

245 else left". ustem t= true; 

246 over »» over + 2; 
24? end; 

248 until (over > lastover) or (nodecount <= 0); 

249 pos t= (left". pos + right*. pos) div 2; 

250 end 

251 else 

252 L*.lstem := false; 

253 if pos > maxposition then maxposition 

254 else 

255 if pos < minposition then minposition := pos; 

256 L*.pos := pos; 

257 en6} (* if N = nil *) 

258 end; (* Position *) 
259 

260 begin (* Treeprint *) 

261 

262 (* Initialize various variables. *) 

263 
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(* Do various width and length calculations. *) 

if pagesize > 512 then pagesize := 512; 
width := abs (horikeylength) +4; 
stemlength := abs (vertkeylength) + 1; 
vertnodelength r= 3 * abs (vertkeylength) +4; 
if (width mod 2) = then width := width + 1; 
pagewidth := pagesize div width; 

(* Construct our data structure and compute positions. *) 

oldL := position (tree, lines, 0) ; 

(* If the horizontal reverse option is selected, reverse 
every node on every line of the data structure. It is 
also necessary to switch around the states of the USTEM 
flags that tell who connects above a given node. *) 

if horikeylength < then 
begin 

H := lines; 
while H <> nil do 
begin 

H\ first". pos := maxposition - 

H*. first*. pos + minposition; 
if H".f irst*. ustem then 
begin 

H*. first*. ustem := false; 
endloop := true; 
end 
else 
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endloop := false; 
L := nil; 

while H*. first*. next <> nil do 
begin 

H*. first*. next*. pos := maxposition - 

H*. first*. next* .pos + minposition; 
if H*.f irst*. next *.us tern then 
begin 

if not endloop then 
begin 

H*.f irst*. next* .ustem := false; 
endloop := true; 
endr 
end 
else 

if endloop then 
begin 

H*. first* .next*. ustem := true; 
endloop := false; 
end; 
oldL := H*. first*. next; 
H*. first*. next := L; 
L := H*. first; 
H*. first • = oldL; 
end; 

H*. first*. next := L; 
H := H*.next; 



end; 
end; 

(* If the vertical reverse option is selected t reverse the 
entire tree on the vertical axis by flipping all the 
head nodes along the edge. Arc reversal is handled in 
the actual arc generation routines. They will scan the 
previous line of info instead of the current one. *) 

slines := lines; 

if vertkeylength < then 

begin 

H := nil; 

while lines*. next <> nil do 

begin 

D := lines*. next; 
lines*. next := H; 
H := lines; 
lines := D; 
end; 

lines*. next := H; 
end; 

(* Break up entire width into pages and loop over each. *) 

startposition := minposition; 

while startposition <= maxposition do 

begin 

page (treefile); 

H := lines; 

while H <> nil do 

begin (* Loop over all lines possible. *) 
oldL := H*. first; 
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repeat (* Find a node on current strip. *) 
endloop :- true; 
if oldL <> nil then 

if oldL~.pos < startposition then 
begin (* Reject this node. *) 
oldL :=* oldL*. next; 
endloop := false; 
end; 
until endloop; 

for i := 1 to vertnodelength do 

begin (* Loop for each print line in a node. *) 
L :- oldL; 
p := startposition; 
while (p < startposition + pagewidth) and 

(L <> nil) do 
begin (* Scan for nodes we need to draw. *) 
if L'.pos = p then 

begin (* Found node at current position. *) 
if (i <= stemlength) then 
begin (* Draw upper stem part of node. *) 
for w := 1 to (width div 2) do 

cout ( ' ' ) ; 
if ((vertkeylength < 0) and L~.lstem) 
or ((vertkeylength >= 0) and 
(H <> slines)) then cout (**•) 
else cout (' ' ) ; 
for w := 1 to (width div 2) do 
cout (' '); 
end 
else 

if (vertnodelength - i) < stemlength then 
begin (* Draw lower stem part of node. *) 
for w := 1 to (width div 2) do 

cout (' '); 
if ((vertkeylength >= 0) and L~.lstem) 
or ((vertkeylength < 0) and 
(H <> slines)) then cout (•*•) 
else cout (' ' ); 
for w :■ I to (width div 2) do 
cout ( ' • ) ; 
end 
else 
if (i >= stemlength + 2) 

and (i <= stemlength * 2) then 
begin (* Print node identifier. *) 
cout ('**); 
cout ( ' ' ) ; 
cdump; 
printkey (i - stemlength - 1, 

abs (horikeylength) , L~.pnode); 
cout ( ' ■ ) ; 
cout ('*•); 
end 
else 

for w := 1 to width do cout ('*•); 
L := L~.next; 
end 
else 

for w := I to width do cout (* '); 
P :* P + 1; 
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end; 
ctrim; 
end; (* for *) 

(* Select the proper line to obtain arc info from. *) 

if vertkeylength >= then 
begin 

if iT.next <> nil 

then L := H~ .next" .first 

else L := nil; 
end 
else L := H". first; 

p := startposition; 

while (p < startposition + pagewidth) and (L <> nil) do 

begin 

endposition := L'.pos; 
beginposition := L~.pos; 
if L~.ustem then 

while (L^.next <> nil) and L^.ustem do 
begin 

L := L^.next; 
endposition := L".pos; 
end; 
L := L'.next; 
if (beginposition < startposition + pagewidth) 

and (endposition >= startposition) then 
begin (* Found an arc we should draw. *) 
while p < beginposition do 

begin (* Space over to proper position. *) 
for w := 1 to width do cout (' '); 
p := p + 1; 
end; , 

if beginposition = endposition then 
begin (* Case of one node directly below. *) | 
for w := 1 to (width div 2) do cout (• •); 
if H <> slines then cout('*') 
else cout(* '); 

for w := 1 to (width div 2) do cout (» '); 
p := p + 1; 
end 
else 

begin (* Normal multi-segment arc, then. *) 
if p = beginposition then 
begin (* Begin with a half segment. *) 
for w := 1 to (width div 2) do 

cout ( ' ' ) ; 
for w := (width div 2) to width-1 do 

cout (**•); 
p := p + 1; 
end; 
while (p < endposition) and 

(p < startposition + pagewidth) do 
begin (* .Connect to the end segment. *) 
for w := 1 to width do cout ('*'); 
p := p + 1; 
end; 

if p < startposition + pagewidth then 
begin (* Draw end segment of the arc. *) 
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end; 



for w := (width div 2) to width-1 do 

cout (•*'); 
for w := 1 to (width div 2) do 

cout ( • • ) ; 
P :* P + l; 



end; 
end; 
end; 
ctrim; 

(* We have now finished an entire line of tree. *) 

H := IT. next; 
end; (* while HOnil *) 

(* Start up on a new page of material. *) 

startposition := startposition + pagewidth; 
end; (* while startposition <= maxposition *) 

(* All output is finished. It is now time to close out our extra 
data structure. *) 

while lines <> nil do 

begin (* Collect a line of stuff and dispose. *) 
H := lines" .next; 
while lines". first <> nil do 
begin (* Kill a node. *) 

L := lines". f irst" .next; 
dispose (lines". f irst) ; 
lines". first := L; 
end; 

dispose (lines) ; 
lines := H; 
end; 

end; (* Treeprint *) 

end. (* Of module TREEPRINT *) 



f**********************,^ 
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LABEL 
13; 

CONST 

minchar = 1 <This is the ordinal of the smallest character not to 
be ignored, i.e. In this case only nulls are ignored.}; 
na'x depth = 64 {This should be 2**n, where n is the number of bits 

per character in the character set.)? 
maxlength * maxdepth; 
maxint = 34359738367; 
bit-size *: 36 (Number of bits per machine word); 



11 The author grants permission to copy for non-profit use, providing 

12 this comment remains. 
13 

14 } 

PROGRAM compressdn-flle, out_file); 
< 

This program takes a text file and creates a compressed 

18 version using Huffman codes. Savings average 30-40%. The compressed 

19 file can be restored to normal using the sister program called 

20 "RECALL". 

21 } 
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TYPE 

bit = 0.. 
out«word 
alphabet 
newchar * 



l; 



PACKED ARRAY ti 
minchar . . 127; 
RECORD 

length: 0.. maxdepth; 
ncnar; PACKED ARRAY tl. 
end; 
treept ». * tree; 
tree s RECORD 

sum: integer; 
left, right: treept 
END; 



bit«sizeJ OF bit; 



maxdepth! OF bit 



VAR 



num-in-chars, num-out-words: integer; 

pos: integer; 

*d: out-word; 

in-file: text; 

out-file: FILE OF out.word; 

tally: ARRAY (alphabet! OF RECORD 

marked: boolean; 
num-of: integer 
END; 
trees: RECORD 

t-num: 0.. maxiength; 
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trs: ARRA* 11.. maxlength) OF treept 
END; 
newcharset: ARRAY (alphabet! OF newchar; 
stack:: newchar; 



PROCEDURE get-char; 

BEGIN 

REPEAT num-in-cnars :* num-in-chars ♦ 1; 

UNTIL eof(ln.file) OR (ord(in-f lie*) <> 0) 
END < GET-CHAR); 



get (ln^flle) 



PROCEDURE fill-tally; 

(Scan the file the first time and get a character count on 
77 which to make the new Huffman character set.) 
78 
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VAR 

count: integer? 

BEGIN 

reset(in-fiie); . :, ?. 

FOR count : = minchar .TO 127 do 
with taliytcount) DO 

BEGIN marked :* false; num-of := END; 
IF NOT eof(in-file) 
THEN 

BEGIN 

get-char; 

WHILE not eof(In-file) DO 
BEGIN 

IF ord(in-file*) < minchar THEN 
BEGIN 

writeln(tty, 'Bad character in lnputl*G', ord( 

In-f lie*)); 
GOTO 13 
END; 
tally tordUn-file-n. num-of :* tallyford(in-f lie*) 
3, num-of ♦ 1; 
get-cnar; 
end 
END 
END (FILL-TALL*); 



PROCEDURE exchangee VAR x, y: integer); 



temp: integer; 
BEGIN temp := x; x := y; y :« temp END (EXCHANGE); 



PROCEDURE make-new-chars; 

(MaKe the Huffman characters based on the character frequencies 
117 of the file.* 
118 

119 VAR 

120 temp: treept; 
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posl, pos2, count: integer; 
done, trl, tr2: boolean; 



PROCEDURE ground(t: treept; val: integer); 
ound the character tree with nil's* 

BEGIN 

with tr DO 

BEGIN left := nil; right :* NIL; 
END (GROUND); 



sum :« val END 



PROCEDURE get-2-minsCVAR posl, pos2: integer; VAR trl, tr2: 
boolean); 
nd the two characters or character trees with the smallest 
guencles.) 

VAR 

count, mini, min2: integer; 

BEGIN (GET.2-MINS) 

mini := maxint; mln2 := maXint; 
FOR count := minchar TO 127 DO 
with tallylcount) DO 
IF NOT marked 
THEN 

IF num-of < min2 
THEN 

IF num_of < mini 
THEN 

BEGIN 

min2 := mini; 
pos2 := posl; 
trl :« false; 
END 
ELSE 

BEGIN 

pos2 := count; 
min2 :s num-of 
END; 
fop count ;s 1 TO trees, t-num Do 
WITH trees, trstcount) * DO 
IF sum < <nin2 
THEN 

IF sum < mini 
THEN 

BEGIN 

min2 :s mini; 
posl := count; 

END 
ELSE 

BEGIN 

min2 := sum; 
END; 
IF NOT trl THEN tallylposl). marked := true 
IF not tr2 THEN tallytpos23. marked := true 



tr2 := trl; 
posl := count; 
mini :* num— of 



tr2 :« false; 



tr2 := trl; pos2 := posl; 
trl := true; mini := sum 



tr2 



true; 



oos2 := count 



END (GET-2-MINS); 
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BEGIN (MAKE.NEW.CHARS) 
trees, t_num := 0; 
REPEAT 

get.2-mlns(posl, pos2, trl, tr2); 

IF trl AND tr2 

THEN 

with trees 00 

BEGIN ; » 

IF pos2 < posl THEN exchangetposl , pos2)|?, 
ne« (temp); v 

temp*\. sum : = trstposlJ *. sum ♦ trs(pos2J .,% sum? 
temp*,, left := trstposl); 

temp*., right ; = trsfposZ); trstposl) :» temp? 
t_num :s t«num • 1? 
FOR count : = pos2 TO t.num DO 
trstcount) :« trstcount ♦ 1J 
END 
ELSE 

IF WOT trl AND NOT tr2 
THEN 

with trees do 

BEGIN 

t.num : = t-num + 1; newCtrs (t.nural ); 
WITH trs[t_num] * DO 
BEGIN 

sum : = tallytposll. num.of + tally tPos21. 

num-of ; 
newtleft); new(rlght); 
groundCleft, posl); groundCright, pos2) 
END 
END 
ELSE 

WITH trees DO 
BEGIN 

IF tr2 THEN exchangeCposlr pos2); 

nesrCtemp); 

temp*., sum :a trstposlJ *. sum + tally[pos23. 

num_of ; 
temp% left : = trstposlJ; new(temp*. right); 
ground(tetnp% r£ght, pos2); trstposl) :« temp 
end; I 

done :=' true; 
FOR count :» mlnchar TO 127 DO 

done := done AND tallytcount) . marfced 
UNTIL done AND (trees, t-num *. 1) . 
END <MAKE_NEW_CHARS>; 



PROCEDURE get„new„.char„set; 

(Taice the Huffman character set out of tree form and into array 
forsi, so as to mafce accessing easier.) 



procedure next-charttpt: treept); 

BEGIN 

IF tptr. right <> nil 

THEN 

WITH StacK DO 
BEGIN 
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length :s length + 1; nchar [length) s* 0? 

next«char(tpt'. right); nchar Clength) :« i; 

next-char(tpt*. left); length : = length - 1 
END 

ELSE newcharset ttpt*. sum) :« stacic 
END (NEXT.CHAR); 



BEGIN <get_new«char.set) 

stacK. length :* 0; next.char(trees. trstU) 

END {get.new^char.set); 



procedure put.wordd: bit); 
{Add a bit to tne output buffer word and print when full.) 

BEGIN 

pos := pos * 1; wdtpos) : = i; 

IF pos a bit.size THEN 
BEGIN 

num».out_words :* num^out.words + 1; pos fa 0; 
out-file*. :* wd; put(out_f lie) 

END 
END (PUT.WORD); 



PROCEDURE flush; 
(Print out the final word, preceded by its length.) 



PROCEDURE convertCi: integer; VAR w: out_word); 

VAR 

con: RECORD 

CASE boolean OF 

true: (j: integer) (Note: it Is assumed that 
■ :~ * an integer taice* up exactly one word#>; 

'. ■> false: (wd: out|.word) 
END; ,/ 

ij ,? 

BEGIN con. 1 := t; w : = con. wd END (CONVERT) ? 



BEGIN (FLUSH) 
IF POS <> 
THEN 

BEGIN 

num«.out .words :a num«.out_words ♦ l; out«.file* sa wd; 
put(out-flie) 
END 
ELSE pos := bit.size; 

num-out-words :* num.out-words + 1; convertCpos, wd); 
outwfiler :s wd; put(out_f lie) 
END (FLUSH); 



PROCEDURE write.lntegerd: integer); 
(Print an Integer bit Qf bit.) 



VAR 
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(1 DIV pow-2) * POW-2; 



pow-2: integer; 

BEGIN 

pow-2 := maxdepth; 
REPEAT 

put-word(i Div pow.2); 
pow-2 :e pOW-2 DIV 2 
UNTIL POW-2 » 
END (WRITE-INTEGER); 



PROCEDURE put-new-charCVAR ch: newchar); 
(Print a Huffman enaracter»> 



count: integer? 

BEGIN 

WITH ch DO 

FOR count ss i to length DO 

BEGIN put-word(nchar [count!) END 
END (PUT-NEW-CHAR); 



PROCEDURE init-OUt; 

(Print the generated Huffman character set into the beginning of 
the file, so that "RECALL" can restore the file.) 

VAR 

I, i: integer; 

BEGIN 

rewrite (out-file); 
FOR i :* minchar TO 127 DO 
BEGIN 

wrlte-integerCnewcharsetlll • length); 
put-new-char (newcharsetti) ) 
END 
END (I NIT-OUT); 



PROCEDURE translate; 

(Scan the file a second time, only change from the standard 
character set to the new one.) 

BEGIN 

inlt-out; reset(in-fiie); 
IF NOT eof(In-file) 

THEN 

BEGIN 

IF ordUn-flie*.) s THEN get-char; 
WHILE NOT eof(ln-file) DO 
BEGIN 

put-new-charCnewcharsettordtin-file*))); 
get-char; 
end; 
flush 

END 
END (TRANSLATE*; 
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PROCEDURE print-stats; 

(Print the number percentage of pages saved. Note; The DEC-20 
stores files by units of pages which are 512 words each,) 

FUNCTION pagesCi: integer); integer; 

BEGIN 

IF I MOD 512 = THEN pages Ss i DIV 512 
ELSE pages S» i DIV 512 ♦ 1 

END (PAGES); 



BEGIN (PRINT-STATS) 

num-in-chars := num-in-chars DIV 2; 
IF num-in-chars mod 5=0 
then num-in-chars : = num-in-chars DIV 5 
ELSE num-in-chars s« num-in-chars DIV 5 ♦ 1; 
writelnCtty, There has been a ', ( (pages Cnum_in-chars) • r 
(num-out-words)) / pages (num-in-chars)) * 100: 2: X, 
'% saving on your file.') 
END (PRINT-STATS); 

BEGIN (MAIN) 

writelnCtty, 

•Version 2.02 of Compress'); 

pos := 0; num-in-chars :s 0; num-out-words : = 0; 

writelnCtty, 'Scanning.'); fill-tally; 

writelnCtty, 'Calculating.'); malce-new-chars; 

get-new-char-set; writelnCtty, 'Compressing.'); translate; 

print-stats; 13: 
END (MAIN). 
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PROGRAM recall(ln_flle, out-file)? 
{ 

This program reads the Huffman codes printed in the 

18 beginning of a file produced by the sister program, "COMPRESS" 

19 and restores the rest of the file to its original form. 
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LABEL 
13; 



CONST 

minchar s 



1 



maxdepth 



{This is the minimum recognizable character 
(nulls are ignored)*? 
64 {This number should correspond to the one for 
maxdepth in "COMPRESS")? 
maxlength * maxdeoth? 
maxlnt * 34359738367? 

bit_size »: 36 4This number should correspond to the one for 

COMPRESS")? 



bit-size in 



TYPE 

Dit * 0., t? 

in-word s PACKED ARRAY CI.. bit-SlzeJ OF bit? 

alphabet = minchar . . 127? 

old-char = RECORD 

length: o. # maxdepth? 

nchar: PACKED ARRAY £1.. maxdepth] OF bit 
END? 

treept « * tree? 
tree = RECORD 

CASE fruit: boolean of 
true: (ch: alphabet)? 
false: (left, right: treept) 
END; 



VAR 



in.flle: FILE OF in-word? 
out-file: text? 
branch: treept? 
inpl, lnp2: in-word? 
num-left, pos: 0,. bit-size; 
hay.dos, done: boolean? 
depth: integer? 



PROCEDURE init? 
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BEGIN 

new(branch)? branch*., fruit :« false; branch*, left *« HILl 
branch*, right :« NIL? reset(ln-flle); inpi :» in-file*; 
get(in-file); inp2 :» in-filer; get(in-flle); pos m t; 
hay-dos :* true; done :* false 

END UNIT); 

FUNCTION get-bit: bit; 

VAR 

con: record 

CASE boolean OF 

true: (int: integer); 
false: (w: in-word) 

END; 

BEGIN 

IF NOT eof(in-file) 

THEN 

IF pos < bit-size 

then begin get-bit :* inpltpos); pos :« pos ♦ 1 END 

ELSE 

BEGIN 

get-bit :« inpltbit-sizel; pos :« I; inpl t« inp2; 
Inp2 := in»file*.| get(Iiufiie) 

END 
ELSE 

BEGIN 

IF hay-dos THEN 
BEGIN 

con. w :* inp2; num-left t« con. int ♦ pot; - if 
hay-dos :* false 

END; 
get-bit :« inpltpos); 
IF pos » nun-left THEN done :« true 
ELSE pos :* pos ♦ l 

END 
END {GET-BIT) ? 



PROCEDURE fill-tree; 
VAR 



i: integer; 
save-tree: treept; 



FUNCTION get-Integers integer; 

VAR 

PO*-2, ans, count: Integer; 
BEGIN 

pov-2 :s maxdepth; ans t« 0; 
FOR count :* i TO 7 DO 
BEGIN 

ans : a ans ♦ pow-2 * get-bit; pow-2 :■ oow-2 DI* 5 

end; 
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get.lnteger :« ans 
END {GET-INTEGER>? 



PROCEDURE add-one(num-left: integer; var ich: alphabet? var tr: 
treept); 



procedure start (var t: treept)? 

BEGIN 

IF t s NIL THEN 
BEGIN 

new(t)? tr. fruit := false? t*. left :« NIL? 
tr. right :s nil 
end 

END <START>? 



BEGIN {ADD-ONE) 

depth := depth + 1; 
IF depth > maxdepth THEN 
BEGIN 

writeln(tty, 

•Your file is not compatible with this program I *G')? 
GOTO 13 
END? 
IF num-left « 

THEN BEGIN tr*.. fruit :* true? trr. ch :* )ch END 
ELSE 

IF get-bit « 
THEN 

BEGIN 

startctrr. left)? 

add-one( num-left - 1, Kh, trr. left) 

END 
ELSE 

BEGIN 

start (trr. right)? 

add-one(num-left - 1, kh, trr. right) 
END? 

depth 5= depth • 1 
END {ADD-ONE)? 



BEGIN {FILL-TREE) 

save.tr ee := branch? 

FOR i : = mincnar TO 127 DO add-one (get-integer, I, branch)? 

branch :* save-tree 

END {FILL-TREE) ? 



PROCEDURE translate? 



PROCEDURE convertCt: treept)? 

BEGIN 

IF tr. fruit THEN vrite(out-fiie, chr(t*. ch)) 
ELSE 
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IF done 

THEN writeln(tty, 'Warning! Character mismatch!*G' ) 

ELSE 

IF get-bit = THEN convert(t". left) 
ELSE convert(t*. right) 
END {CONVERT*? 



BEGIN {TRANSLATE) 

rewrite(out-file)? 
END {TRANSLATE)? 



WHILE NOT done DO convert (branch) 



BEGIN {RECALL) 

writeln(tty, 

•version 2 

writelnUty, 

writelnUty, 

END {RECALL). 



of Recall (Not coppatabie with version 1)1')? 
'Initializing.')? init? depth := 0? fill-tree? 
'Recalling.')? translate? 13: 
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Abstract 

The translation-time and run-time performance of three CP/M-based 
Pascal translators — Sorcim's Pascal/M, MT MicroSYSTEMS' Pascal/MT + , and 
Ithaca InterSystems' Pascal/Z — are compared. Using a benchmark of eight 
programs on a 4MHz 280-based microprocessor, we find that Pascal/M excels 
in translation time and that Pascal/Z excels in run time. Pascal/MT +, s 
translation time approaches that of Pascal/M for long programs. Several 
translator limitations are also illustrated by the benchmark. 

Introduction 

We recently had the opportunity to use and evaluate four 
micropro essor-based Pascal translators. We are reporting here the results of 
one aspect of this evaluation (namely, performance) for three of them. 

The performance of a piece of software, such as a programming language 
translator, is measured in terms of the amount of resources required by the 
software to produce some useful result. The primary resource we are 
interested in is time. We measured both the time required to translate a 
source program into a machine-executable form and the time required to 
execute the translated program. The former is termed translation time and 
the latter run time (or execution time) . 

The three Pascal translators we evaluated are Sorcim's Pascal/M, 
MT MicroSYSTEMS' Pascal/MT + , and Ithaca InterSystems' Pascal/Z. All three 
run under Digital Research's CP/M operating system. We also evaluated a 
fourth translator, the UCSD Pascal system, which runs under its own 
operating system. We have excluded UCSD Pascal from our report because we 
do not feel a fair comparison of translator performance can be made across 
operating systems. Separating the performance attributable to the operating 
system from that attributable to the translator is a difficult task. Other 
translators beside these three run under CP/M, however. We limited the 
study to translators that accept essentially the full Pascal programming 
language and that are widely accessible to the general microcomputing public. 
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Not-for- 



Thus we eliminate from consideration several "tiny" Pascal translators, among 
others. 



Translators 



To better understand the behavior of the three Pascal translators and to 
better appreciate the performance results, we begin with a brief introduction 
to translator construction. We use translator in the generic sense — any 
software system that accepts as input a program in one language (the source 
language) and that produces as output a functionally equivalent program 
written in another language (the object language). If the source language is 
a high-level language such as Pascal and the object language is a low-level 
language such as assembly language or machine language, then the translator 
is called a compiler. If both the source and the object languages are low- 
level, then the translator is called an assembler. If the object language is 
not the machine language of some real machine, it becomes necessary to 
execute the object code with an interpreter, which simulates the object 
language on a real computer. 

Compilers that translate source programs directly into object programs 
are called one- pass compilers. Sometimes compilers are written to perform 
one or more intermediate transformations between source and object; these are 
called multi-pass compilers. Multi-pass compilers generally take longer than 
one-pass compilers, but they often require less main memory, compile longer 
source programs, provide more complete diagnostics, and generate better 
object code. To conserve main memory (and again to increase the size of 
source programs that can be translated), multi-pass compilers often write out 
their intermediate transformations to temporary disk files. 

We used version 3.19 of the Pascal/M translator. It is patterned after 
the UCSD Pascal system, comprising two components: a compiler that 
translates a Pascal source program into P-code — object code for a fictitious, 
Pascal-like P-machine — and an interpreter for the P-machine. It is a one- 
pass compiler written in Pascal. For short and moderately-sized programs the 
compiler uses no memory overlays, but long programs require swapping from 
the disk of segments of the compiler. It runs in 56K of main memory and 
requires no temporary files. The output from the compiler is a file containing 
P-code instructions, which is input to the P-machine interpreter. For 
compactness and efficiency, the interpreter is written in the assembly 
language of the host computer (a Zilog Z80, in our case). 

We used version 5.2 of the Pascal/MT + translator. It is a true compiler 
that generates object code for any of several microprocessors, including the 
Z80. It is a three-pass compiler written in Pascal: the first pass converts a 
source program into a sequence of logically related characters called tokens, 
the second pass builds a symbol table, and the third pass generates object 
code and places it in a Microsoft-format, relocatable object file. The compiler 
runs in 56K of main memory, using five memory overlays, and it uses one 
temporary file for the tokens. 



We used version 3.2 of the Pascal/Z translator. It is also a compiler, 
but it generates an assembly-language program as its output. This assembly 
language requires a special assembler that is supplied with the translator, 
which can only generate Z80 object code. Pascal/Z is a one-pass compiler 
written in Pascal. It requires 56K of main memory (although 64K is 
recommended) , using one memory overlay, and it requires no temporary files. 

Benchmark 

To adequately compare performance, we needed a benchmark — - a point 
of reference for our measurements. A benchmark for a translator is a 
collection of source programs, written in the language the translator 
understands, that exercises various aspects of the translator's capabilities. 
Such benchmarks generally include short programs, long programs, and 
programs that stretch the limits of the translator, such as programs with 
deeply nested control structures or large data storage requirements. The 
idea is to include a mix of programs that are representative of the programs 
that the translator will encounter in normal, everyday use. 

Rather than develop our own benchmark from scratch, we relied heavily 
on the work of others. In particular, seven of the eight programs in our 
benchmark were adapted from a performance study of the CDC 6400 Pascal 
translator running under the SCOPE 3.4 operating system, made several years 
ago by Niklaus Wirth, the designer of Pascal. We restricted our adaptations 
exclusively to the removal of implementation-dependent features, such as the 
presence of a hardware clock on the CDC 6400 and the maximum size of 
integers and reals. It is important to note that we made no other 
modifications to these programs. Several of them would not compile under one 
of the translators. We probably could have modified these programs to make 
them compilable. We opted instead to let our evaluation rest on a translator- 
independent benchmark. 



The first benchmark is a 47-line program to compute the first 90 positive 
and negative powers of 2. The algorithm uses integer arithmetic exclusively, 
including multiplication and division. No standard Pascal functions (such as 
SQRT) are used, and arbitrary precision is simulated by storing each digit of 
the result separately in the elements of an array. "Powers of Two" is a 
useful benchmark since it heavily exercises integer arithmetic. 

The second benchmark is a 43-line program to sort a 10,000-element 
array of arbitrary integers into ascending order. The sorting algorithm is 
called Quicksort, which relies extensively on a recursive procedure. The 
maximum depth of recursion is /n(10,000)=10. "Quicksort" is useful since it 
exercises recursion and array manipulation. 

The third benchmark is a 32-line program to write and to read a file 
containing 1000 real numbers. First the numbers are written out, one per 
record, to a file. Then the file is reset and the numbers are read back in. 
The numbers are stored in internal format (that is, not in human readable 



form); no input/output conversions are performed. "Real 10" is useful since 
it exercises "naked" file handling. 

The fourth benchmark is a 51 -line program to solve the "eight queens" 
problem. The problem is to find the 92 configurations of eight queens on a 
chessboard such that no queen attacks another queen. The algorithm uses 
backtracking and recursion to exhaustively try all plausible chessboard 
positions. "Eight Queens" is useful since it heavily exercises iterative 
constructs such as for-loops and if-then-else statements, together with simple 
but repetitive array manipulation. 

The fifth benchmark is a 47-line program to compute the first 1000 prime 
numbers. "Primes" uses essentially the same language features as Powers of 
Two, but involves more computations. 

The sixth benchmark is a 29-line program to compute the ancestors of a 
group of individuals, given their parents. It uses a lOOxlOO-element Boolean 
matrix to represent the individuals and the parent/offspring relationships 
among them. "Ancestor 1" is useful since it contains deeply nested control 
constructs and two-dimensional arrays, and thus exercises these aspects of a 
translator's capacity. 

The seventh benchmark is a reimplementation of the previous one, using 
a 100-element Pascal set in place of a Boolean matrix. "Ancestor 2" is useful 
for comparing the performance of the implementation of sets. 

The last benchmark is a 280-line program we wrote to compute the 
position of the moon at a given time and date. The program uses nine real 
arrays indexed by enumerated types, two record types, ten internal 
functions, and five internal procedures. Most of the functions are one-line 
long, and do such things as calculate the trigonometric functions in degrees 
and convert to and from radians and degrees. "Moon Position" is a useful 
benchmark since it heavily exercises real arithmetic and the compiler's 
capacity to handle moderately long programs. 



Hardware 

All of our benchmark programs were run on NorthStar Horizons, 
containing 4MHz Z80 microprocessors, 56K of main memory, and two double- 
density, single-sided 5-1/4-inch Shugart SA400 floppy disk drives. Although 
some of the manufacturers claim their translators will operate on smaller 
systems, we believe our system is the minimum configuration required for 
reasonable response and minimal frustration. All three translators were run 
under CP/M 2.2, using the NorthStar version distributed by Lifeboat 
Associates. 



Methods 

For each translator we first verified that each of the benchmark 
programs produced the correct results. We then removed all statements that 
wrote to the terminal screen, except for a WRITELN at the beginning of each 
program that wrote "GO" and a WRITELN at the end of each that wrote 
"STOP". We did not use these output messages for our measurements; they 
were merely to give us feedback that something was happening. To 
guarantee comparable run-time statistics, we compiled each program with all 
error checking, such as range checking and 10 failure detection, disabled. 

Because NorthStar Horizons are not equipped with hardware clocks, all 
timing measurements were made using a stopwatch. We timed each separate 
step (compile, assemble, link, and run) by typing the appropriate CP/M 
command line, waiting for the disk drives to stop spinning, and then 
simultaneously hitting the RETURN key and the start button on the 
stopwatch. We stopped the watch when the next CP/M command prompt 
("A>") appeared. Thus all of our measurements include the time required by 
CP/M to process the command line, to locate and load the appropriate software 
into memory, and to prompt for the next command. This method does not 
measure the "bare bones" performance of the three Pascal translators and the 
object code that they produce. Nevertheless, we believe that it reflects the 
typical user's interactions, and thus the method accurately measures the 
performance that such users can expect for themselves. 

Several of the measurements were taken twice to check for timing 
variance. In no case did the times differ by more than 0.3 seconds, which 
we attributed to variations in controlling the stopwatch. Thus the variance 
appeared insignificant. 

Results 

Tables 1 thru 3 show the results of translating and executing the 
benchmark programs with each of the three translators. Each column in the 
tables represents one CP/M command. Tables 4 and 5 summarize the results 
of the first three tables. In Table 4 translation time is computed as the sum 
of all the steps necessary to make the object programs executable. 

Table 1 shows that Real 10 would not compile under Pascal/M. Pascal/M 
does not support the READ and WRITE procedures on the type FILE OF 
REAL. As expected with an interpreter-based system, Pascal/M compiles 
quickly, but interpretation of the P-code is slow. Compile time remained 
approximately 80 lines of source code per minute, even with long programs 
such as Moon Position. 



Pascal/MT + successfully compiled all the benchmark programs (Table 2). 
Compilations are typically up to three times longer than with Pascal/M; total 
translation time is up to four times longer. Nevertheless, run time ranges 
from about 30% to 200% faster. Compile time was approximately 30 lines of 



code per minute for the short programs, but rose to 70 lines per minute for 
the long program. Total translation time was about 25 lines per minute for 
the short programs and 56 lines per minute for Moon Position. 

Two of the programs would not compile under Pascal/Z (Table 3). Both 
had control structures too deeply nested (about eight levels) for the compiler 
to handle. Pascal/Z's compile time is only about one-third longer than 
Pascal/M's and about twice as fast as Pascal/MT + 's for short programs 
(approximately 65 lines per minute). But the extra assembly step required 
takes up to twice as long as the compile time. Table 4 shows that the overall 
translation time of Pascal/Z is three to four times slower than Pascal/M and 
ranges from about 25% to 200% slower than Pascal/MT + . Translation time for 
long programs decreased slightly (25 lines per minute as opposed to 20 lines 
per minute). Nevertheless, Pascal/Z consistently produced faster code than 
did Pascai/MT + , ranging from about 10% to 150% faster. 

Conclusions 

For applications that require frequent compilation but infrequent 
execution, or where run-time speed is unimportant, Pascal/M is a good 
choice. 

Pascal/Z is the best alternative when run-time performance is paramount 
and your code only needs to run on Z80s. But be prepared for 
excruciatingly slow translation time, especially on long programs. Also be 
prepared to restructure your programs to get them to compile, especially if 
your system has less than 64K of main memory. 

Pascal/MT + lies somewhere between these extremes. Translation time is 
slow, but the relative speed (that is, lines of code per minute) improves 
significantly as program size increases. Similarly, run time is much better 
than Pascal/M, but not as good as Pascal/Z for most programs. Run-time 
performance for the two recursive benchmarks, Quicksort and Eight Queens, 
was relatively poorer than for the nonrecursive benchmarks. 



We conclude with a strong admonition. We have reported here only one 
aspect of comparison between the three translators, namely time performance. 
There are many other aspects that must be considered when deciding on a 
translator to suit your own needs, such as robustness, documentation, 
support, language extensions, error handling, size of object code, and ease 
of use. For example, in applications where reentrant code is important, 
Pascal/Z is the only alternative of the three. We decided on Pascal/MT + for 
our own applications, primarily because of the language extensions it provides 
(it is the most complete systems implementation language of the three) and its 
robustness (we seldom have to massage our code to get it to compile). 
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Program 


Compile Time 


Run Time 


Powers of Two 


34.6 


29.5 


Quicksort 


32.3 


5:23.0 


Real 10 


unsuccessful 


N/A 


Eight Queens 


36.1 


5:02.8 


Primes 


33.9 


1:13.8 


Ancestor 1 


32.3 


1:51.3 


Ancestor 2 


31.5 


43.4 


Moon Position 


3:30.3 


17.4 



Table 1: PascaJ/M Timing Results (in minutes and seconds). 



Program 


Compile Time 


Link Time 


Run Time 


Powers of Two 


1:31.3 


30.4 


9.6 


Quicksort 


1 


30.7 


39.0 


2:47.6 


Real 10 


1 


26.0 


38.7 


37.0 


Eight Queens 


1 


32.8 


30.9 


2:30.5 


Primes 


1 


31.6 


30.3 


11.6 


Ancestor 1 


1 


30.5 


33.6 


24.9 


Ancestor 2 


1 


28.3 


31.5 


23.8 


Moon Position 


3 


59.5 


53.2 


12.8 


Table 2: Pascal/MT+ 


Timinc 


Results 


(in minutes 


and secor 



Program 


Compile Time 


Assembly Time 


Link Time 


Run Time 


Powers of Two 


44.8 


58.0 


46.8 


8.9 


Quicksort 


43.3 


59.3 


48.6 


1:05.5 


Real 10 


38.3 


58.9 


56.1 


20.9 


Eight Queens 


48.0 


1:04.0 


49.7 


53.4 


Primes 


unsuccessful 


N/A 


N/A 


N/A 


Ancestor 1 


unsuccessful 


N/A 


N/A 


N/A 


Ancestor 2 


41.8 


1:03.2 


46.3 


19.0 


Moon Position 


3:34.6 


6:06.5 


1:42.1 


10.5 



Table 3: Pascal/Z Timing Results (in minutes and seconds). 



Program 

Powers of Two 
Quicksort 
Real 10 
Eight Queens 
Primes 
Ancestor 1 
Ancestor 2 
Moon Position 



Lines Pascal/M Pascal/MT + Pascal/Z 



47 
43 
32 
51 
47 
29 
29 
280 



34.6 
32.3 
N/A 
36.1 
33.9 
32.3 
31.5 
3:30.3 



2:01.7 
2:09.7 
2:04.7 
2:03.7 
2:01.9 
2:04.1. 
1:59.8 
4:52.7 



2:29.6 
2:31.2 
2:33.3 
2:41.7 
N/A 
N/A 
2:31.3 
1:23.2 



Table 4: Summary of Translation-Time Results (in minutes and seconds). 



Program 


Pascal/M 


Pascal/MT+ 


Pascal/Z 


Powers of Two 


29.5 


9.6 


8.9 


Quicksort 


5:23.0 


2:47.6 


1:05.5 


Real IO 


N/A 


37.0 


20.9 


Eight Queens 


5:02.8 


2:30.5 


53.4 


Primes 


1:13.8 


11.6 


N/A 


Ancestor 1 


1:51.3 


24.9 


N/A 


Ancestor 2 


43.4 


23.8 


19.0 


Moon Position 


17.4 


12.8 


10.5 



Table 5: Summary of Run-Time Results (in minutes and seconds). 
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MACALESTER COLLEGE 

160Q GRAND AVENUE 

SAINT PAUL, MINNESOTA 55105 

612-696-6000 



October 7, 1981 



Mr* Rick Shaw 
Pascal Users Group 
P.O. Box 888524 
Atlanta, Georgia 30338 

Dear Mr. Shaw: 

The enclosed article reports my reactions and those of my students to the first Pascal 
programming course that I taught. I am fairly new to the field of computer science 
and this particular teaching experience was exciting to say the least. 

1 hope this short piece will prove to be of interest to you and your readers. 

Sincerely, 



<Z 



GeraldR^ f'\iz\ 
Associate Professor 



GRPiba 
End. 
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A Geographer Teaches Pascal — Reflections on the Experience 

Jerry Pitzl 
Macalester College 
St. Paul, Minnesota 



Macalester College, a small (1700 students), liberal arts institution 
located in St. Paul, Minnesota, recently initiated a new major in Computer 
Studies. Several courses in programming have been offered over the years 
but increased student demand for a wider range of offerings and faculty 
recognition that a full and complete program would be necessary in order 
for us to keep pace with the rapidly growing field of computer science 
necessitated this significant change. 

As a further enhancement to the computer program, Macalester College, 
in 1979, became the recipient of a National Science Foundation grant to be 
used to expand the use of computers within sGience laboratory settings. 
Initial purchases of hardware included three DEC MINC-11 computers 
especially configured for laboratory applications. In addition, the 
departments of geography, of which I am a member, and geology received a 
Magnavox S-4 Orion stand-alone graphics system, a 22" x 22" Talos S622 
digitizer, and a 300 LPM Printronix Printer /Plotter. The graphics system 
is used primarily within the geography department in a computer mapping 
course. 

During the academic year 1979-80 I was on a sabbatical leave and spent 
virtually all my time at the University of Minnesota auditing courses in a 
variety of computer and mathematics related areas. I had no prior 
knowledge of computer languages, but I knew that I would have to become 
familiarized as quickly as possible because I was slated to do the computer 
mapping course. Needless to say, the transition to the "kind of thinking" 
required for success in the computer field did not come that easily for me 
at first; my long-term background, primarily in the humanistic realms of 
geography, had produced a "mind set" that was placed in a mild form of 
intellectual shock at first exposure to computer operations, and this 
condition persisted for at least the first few weeks. 

Fortunately, however, my introduction to computer programming was 
through the Pascal language. I found the language to be logically 
constructed and relatively easy to use. The form of program development 
using algorithm formulation and structure provided an ideal transition to 
the eventual writing of actual Pascal code. I soon became unequivocally 
"hooked" on Pascal. So much so that in the following year I set out to 
develop a course in programming with Pascal which was introduced during our 
January "interim" session of 1981. Interim is a one-month period in which 
courses not available in the regular semesters are given. It is a good 
time to introduce and test a topic or theme which may later become a 
regular curricular offering. In our case, Pascal was not a new topic on 
campus; it is being taught along with other languages in a one-semester 
course. However, I felt that the language should receive a great deal more 
emphasis and perhaps eventually be the sole subject of a full semester. It 
is, as most agree, the most appropriate language for teaching the concepts 
of structured programming. 



The interim course contained 20 students, half of whom had varying 
degrees of experience with computer science and the rest with no experience 
whatever. The four-week time frame with two-hour sessions five days a week 
left little free time for either the students or the instructor. We 
covered all aspects of the language including a brief introduction to the 
use of records, external files and the pointer. 

The students produced eight programs of varying difficulty and took 
four quizzes. The assigned readings came from Schneider, Weingart, and 
Perlman, Introduc tion to Progr amming and Prob l em Solv ing with Pascal, a 
widely used and thorough introduction to the language. As an added 
feature, G. Michael Schneider, one of the authors of the text, visited the 
class and gave us a most stimulating presentation. 

As a final exercise in the course, the students were asked to complete 
a critique of the experience. Some of the questions asked and a sampling 
of the responses are presented here: 

Item No. 1 — Did you know a programming language before this course? 

a. If yes, how would you compare Pascal to the language(s) you already 
know? Responses: requires new ways of thinking. . .about flow of 
control; most flexible language I know; much prettier.. .easy to 
use and efficient once the bad habits of needing the "go to" 
statement are broken; easier to understand than COBOL or FORTRAN; 
more high-powered than BASIC and more structured; more can be done 
with Pascal; more ways to approach a problem; compared to BASIC, 
Pascal is much more fun; more closely related to the English 
language. 

b. If no, did you find that Pascal provided a meaningful introduction 
to programming? If yes, why? If no, why not? Responses: Yes, I 
think the structure is important; yes, it provides the basis for a 
new way of thinking; yes, good intro to the computer and how it 
works; yes, judging from the experiences of those in the terminal 
room using other languages, it seems that Pascal is the best 
language for understanding programming; yes, it is easy to work 
with; yes, Pascal has provided me with a meaningful introduction to 
programming; yes, it is easy to read a program. .. and the language 
is interesting; yes, Pascal was a good introduction in that I 
learned that programming is mostly paperwork before hand . 

Item No. T — Do you think that Pascal should be offered as a full, regular 
semester course? If yes, please state why; if no, please state why not. 



Responses: Yes — interesting, powerful; important for computer studies 
majors; good for structured programming; it is a relatively new language 
and computer studies majors should know it; it is the direction that 
computer languages will go; best for general purpose computing; becoming 
more widely accepted and used; valuable course for learning many aspects 
of computer science; better for beginners — neat, beautiful language; 
more time needed than is available during interim; versatility and uses of 
the language are great; better to learn as a "first" language; a "fun" 
language; a "logical" language; very powerful. 



There were no "no's" 

Item No. 9 — Do you think that you will choose to use Pascal in the future 
if you write computer programs? 

All yes's 

How would you rate our guest lecturer, Professor Schneider? 

Responses: good, excellent; interesting; informative; amusing; a good 
prospect for a Mac prof; excellent; very knowledgeable; knows his stuff; 
great future; very good; great — too bad we can't be assured of having 
him here; great teacher; 8 on a scale of 10; excellent; he really knows 
his stuff; excellent; 10 of 10; great; great guy; really knows what 
he's doing; liked him; slick and intelligent guy; fantastic; sparked my 
interest in computer science; the high point of the class; he is like the 
pointer — dynamic. 

Final Item — General comments. 

Responses: best interim course ever taken; more challenging than BASIC; 
impressive language; I now have an understanding and a respect for 
computers; revived my ability to concentrate for extended periods of time; 
computers — "it's rather amazing, isn't it?" 

As the responses clearly suggest, the entire class was more than 
satisfied with the course and unanimous in their assessment of Pascal as a 
sound and usable programming language. It would be sheer understatement on 
my part to say that I was pleased with the outcome. I was ecstatic! The 
course is scheduled for the interim term of 1982 and the Pascal language 
offering during the regular semester will be expanded within the existing 
course framework. 

I conclude with a plea to all who are in an academic setting to 
encourage the expanded offering of Pascal as the most appropriate language 
to use for introducing programming. I believe this to be true not only for 
students, but for others (faculty and staff) who are being tasked to climb 
aboard the expanding computer applications wave that apparently is nowhere 
near cresting. 



*************** 
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An Extension that Solves Four Problems 
by Jonathan A. Yavner 



1. The Dynamic Array. 

The specification of dynamic arrays is currently a point of heated 
discussion among Pascal theorists. Pascal News #19 (labeled "17") 
contains eleven doubie-density pages of de'bate on the merits of the 
proposal contained in the DP 7185.1 standard. The most telling 
argument against the Sale syntax is the assertion that it is not 
intuitively obvious and therefore does not belong in a language whose 
users consider it the guardian of rational programming. The point 
is substantiated by the sheer prolixity of the bombast on the subject 
that has been published in PN, shouted across standards-committee 
conference tables, or otherwise made public. If the dynamic array 
really belongs in Pascal — and is not present because certain vociferous 
fanatics chanting "Stamp out the FORTRAN dinosaur I n want to make Pascal 
able to do everything FORTRAN can and don* t care if Pascal becomes 
FORTRAN in the process — there has to be a better way. 



2. Memory-resident Format 'Convers ion. 

I wonder about those fanatics, though. My company produces 
financial database-management systems, for which one would think Pascal 
an ideal language, given its data-security emphasis. ' However, such 
programming requires certain features commonly available in FORTRAN 
and BASIC which are difficult to simulate in Pascal. Such a feature 
is memory-resident format conversion. In most high-level languages, 
format conversion is performed as an integral part of I/O. Sometimes 
it is necessary to perform such conversion in memory, perhaps to add 
commas before output or to delete them after input. For these 
occasions FORTRAN provides its ENCODE and DECODE statements. BASIC 
implementations tend to have two or more string functions (with dif- 
ferent names and formats for each implementation) to perform these 
conversions. I hear no fanatic-talk about adding these features to 
Pascal, yet the only way to force Pascal to perform non-1/0 conversion 
is to declare an external procedure and then attach it to the appro- 
priate routine in the run-time-library using some sort of aliasing 
mechanism— an extremely implementation-dependent method. If the 
implementation doesn f t support external procedures or doesn' t list 
the names of its library routines or doesn* t allow them to be called 
by the user, the program must contain a source-code duplicate of the 
conversion routine — an extremely inefficient method. 
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This conversion problem is actually a special case of a more 
basic difficulty which has received occasional mention in this journal 
(though I can't find the references). Programming generality can 
be promoted by avoiding an either/or choice for main versus peripheral 
memory storage of files. In one of the references which I can' t find, 
IBM' s 48-bit unified addressing scheme is given as an example of where 
the capability to code storage-location-independent routines As 
provided to the assembly programmer. 

3. The String L 

Anyone who uses a version of BASIC (among others) that has a 
garbage collector becomes addicted to strings and finds Pascal and 
FORTRAN irritatingly restrictive. Like its close relative the dynamic 
array, there seems to be no obvious method of specifying string def- 
inition and manipulation. 

4. Random-acce ss I/O. 

Pascal can be implemented on any computer with at least a pro- 
cessor and two magtapes. Such a computer is incapable of random-access 
I/O. For this reason no mention of such I/O appears in the standard. 
For this reason each of the vast majority of implementations which 
can supply random access has implemented incompatible extensions to 
provide this capability. The standard would be superior if there 
were some way to specify the format of such operations without either 
requiring them of all implementations or layering the standard. Use 
of a layered standard to define a language which includes intuitive 
obviousness among its design goals is a paradox. 



The Solution. 



The solution to the problems delineated above lies in the real- 
ization that dynamic arrays, strings, and files are but different 
facets of the same data structure. Simply extending slightly the 
definition of the file structure would allow files to perform the 
duties of strings and dynamic arrays. To avoid actually implementing 
garbage collection, files could be allocated in segments on the heap, 
each segment containing x sequences of the file and a pointer to the 
next segment, where x is determined from the equation 

x=((nice segment size)- (pointer size)) DIV (sequence size). 

Deletions from the standard; All references to comformant arrays, 
comformant array schemata, and compliance levels. 



Changes t o the standard, 6.4 .3.5 (file types): The file element 
f .M has the enumerated values (Generation, Inspection, Direct) . There 
exists an element f.Len whose value is the number of sequences in 
the file. The notation f[n] denotes the nth sequence of the file? 
the values for n are . . (f .Len-1) . There exists an element f.Pos, 
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whose value is such that f .R.first=f [f.Pos] . F.Pos shall be equal 
to f.Len if f.R«S(). Rule (b) , describing the structure of a file 
of type text in Generation mode, shall apply also for Direct mode. 

Changes to the standard, 6.6.5.2 (file-handling procedures); 

get(f): If fO.M=Direct, 
pre-assert ions : 
fO.L is defined 
fO.R<>S() 
post-assertions: 
f .M=fO.M 
f.Len=fO.Len 
f .Pos=fO.Pos+l 
f .L«fO.L~fO.R. first 
f .R=fO.R.rest 
If f.R<>S() 

ff^f.R. first 
otherwise 

ft is undefined 

put(f): If fO.M=Direct, 
pre-asser tion : 

fO.R, fO.L, and fOf are defined 
post-assertions : 
f .M^fO.M 
f .Pos*fO.Pos+l 
f.L=fO.L~S(fOt) 
f .R=fO.R.rest 
If fO.R=S(), 

f .Len=fO.Len+l 
otherwise 

f .Len=fO.Len 
If f.R<>S() 

f|*f.R. first 
otherwise 

ft is undefined 

Additions to the standard, 6.6.5.2 : 

init(f) 

pre-asser tion: 

true 
post-assertions : 
f .M=Direct 
f.L«f.R=S() 
ft is undefined 
f .Len«f .Pos=0 

seek(f ,p) 

pre-asser tions : 

fO.L and fO.R are defined 
fO.M IN [Direct] +seekmodes 
p IN [C.fO.Len] 
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...~f[p-l] 
"f [f.Len-1] 



(f.L=S() 
(f.R=S() 



if p=0) 

if p=f.Len) 
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post-assertions : 
f .M=fO.M 
f .Len=fO.Len 
f . Pos=p 

f.L-f [0]-f [l]-f [2]' 
f.R=f [p]~f [p+l]~... 
if f.R<>S() 

ft=f,R. first 
otherwise 

ft is undefined 

The implementation-defined set seekmodes shall be equivalent 
to the set of values for f.M other than Direct for which seek shall 
be valid. 

The procedures d<f ctn> (f ,p ,vl ,v2 , . . . ,vn) , where <fctn> shall 
be replacable by any of (read, write, readln, writeln), shall be 
equivalent to 

begin seek(f,p); <fctn> (f ,vl,v2, . . . ,vn) end. 



Additions to the standard, 6.6.5 . 4 (ordin a lf u n ctions) : 

length(f) The function shall return the value of the element f.Len 
of file f; the set of values for f.M other than Direct for 
which f.Len is defined shall be implementation-defined. 

pos(f) The function shall return the value of the element f.Pos 

of file f; the set of values for f.M other than Direct for 
which f.Pos is defined shall be implementation-defined. 

6. Ex ample Pr ogram. 

This program fragment uses many facets of the extension outlined 
above. It has not been parsed, since currently there is no processor 
which accepts the extension. It is asserted tlnat one of Pascal' s 
greatest strengths lies in its ah." .ity to make this kind of general- 
purpose program reasonably port le. Comments would be appreciated, 
as it is conceivable that I may in.. ,ict upon the world a Pascal pro- 
cessor with this extension unless either I am drowned in a sea of 
hate mail or the proposal ceases to be an extension. 



program MoneyMarketlll (input, output) ; 
const 

ScreenHeight = 24; 



ScreenWidth 


= 


79; 




MaxField 


= 


32; 




MaxScale 


= 


9; 




type 








Whole 





. .Maxlnt; 


Short 




32768. 


.32767; 
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Byte 

SHIndex 

SW Index 

ScaleXndex 

FieldTypes 

TableTypes 

Date 

year 

month 

day 

end; 
TypeCross 



= 0..255; 

« 1. .ScreenHeight; 

= 1 . . ScreenWidth ; 

= -MaxScale. .MaxScale; 

* ( A,B1,B2,B4,D,X ) ; 

= ( Control, FieldDesc ); 

= packed record 

1901.. 2100; 

1..12; 

1..31? 



packed record { All implementation-dependent trickery 
goes through this type , thus isolating the programming changes 
necessary to move to a new processor. } 
case FieldTypes of 

: Real ) ; 

: Byte ); 

: Short ) ; 

: Integer ) ; 

: Date ) ; 

: packed array [1. .MaxField] of Byte ); 



( aval 
( blval 
( b2val 
( b4val 
{ dval 
( xval 



A 
Bl 
B2 
B4 
D 
X 

end; 

TableRec = packed record 
case rec type: TableTypes of 
Control : ( { Control record for each data file } 

name : packed array[1..8] of Char; 

fd : Whole { Pointer to first field descriptor }; 

nent : Short { Number of field descriptor entries }; 

FieldDesc : ( { Descriptor for each field in data record } 
fx : Short { Field number }; 
ft ; FieldTypes; 

af : Short j Auxiliary field-type datum } ; 
loc : Short { Location of field J ; 
leng : Byte ( Length of field }; 
p : Byte Screen page of fields }; 
vx,vy : Byte Co-ordinates of value field 
Byte { Co-rordinates of name field 



nx,ny 
name 



packed arraf [1..12] of Char; 



packed file of Byte; 
- file of TableRec; 



* £nd; 

Dafeafile i 

TableFile 
var 

f ilcon : TableRec { File control record } ; 

table : .TableFile; 

data : DataFile; 

filnum ?; : Byte { Data-file number } ; 

page : Byte; 

lnlO : Real; 

procedure Format ( { ENCODE example; also shows string usage } 
var output : Text; 
input t Real; 



scale : Scalelndex; 

leng : Byte \ This semicolon is illegal! -> ^ ; 

}; 



Text; 

Whole; 

0. .MaxScale; 

0..2; 



Number of implied fractional digits } 



ale) ; 
igits 



var 

temp 

nonfrac,x 

abscale 

comma 

begin 

abscale:=abs (scale) 

init (output) ; 

write (output / exp(ln(abs (input) )-abscale*lnlO) :l:absc 

nonfrac:=length (output) -abscale-1 { J3on-f ractional d 

comma := (nonf rac-1) MOD 3; 

init (temp) ; 

seek (output, 0) ; 

for x:=l to nonfrac do begin 

write (temp/Outputf ) ; 

get (output) ; 

if comma>0 then comma :=comma-l else begin 

if xononfrac then write (temp,' ,' ); 

comma: =2; 

end; 

end; 

if scale<0 then begin { Truncate decimal } 

x:=length (output) ; 

repeat 

x:=x-l; 

seek (output ,x) ; 

until outputf <>• 0* ; 

if outputfo' .' then begin 

seek (output ,nonfrac) ; 

for x:=nonfrac to x do begin 

write (temp, outputf) ; 

get (output) ; 

end; -& 

end ; &,' 

r- 
end 

else if scale>0 then while NOT eof (output) do begin 

write (temp, outputf ) ; 

get (output) ; 

end; 
iftit (output) { Space should be recovered here } r ; 
x:=leng-length(temp)-ord (input<0) ; 
if x>0 then write (output ,' ' :x) ; 
if input<0 then write (output,' -' ); 
w,hile NOT eof (temp) do begin 
''i write (output, tempf ) ; 

get (temp) ; 

end; 
if length (output) >leng then begin 

init (output) ; 

for x:=l to leng do write (output,' /') ; 
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end; 
{ System must dispose of local files here. } 
end; 

procedure FormatDate(var output:Text; input : Date) ; 
begin 

init (output) ; 

with input do write (output , day: 2,' /' ,month:2,' /• ,year:4) ? 

seek (output, 3) ; 

if outputt=- ' then write (output,' 0* ) ; 

end; 



procedure Dump(var output, input: Text ) ; 

{ Generalized procedure to trim trailing blanks. This routine is 

completely device-independent. Output is assumed to be open. } 
label 1; 
var 

temp : Text; 
x : Whole; 
begin 

reset(input) { Reset must perform a writeln if necessary }; 
page (output) { Must also writeln }; 
while NOT eof (input) do begin 
init (temp) ; 

while NOT eoln (input) do begin { Note the use of the end-of-line 
character as a flag. Similar use of the end-of-page character 
is impossible because of the lack of the eop() function. } 
write ( temp, inputf ) ; 
get (input) ; 
end; 
readln (input) ; 

if length (temp) =0 then goto 1; 

repeat seek (temp, pos (temp) -1) until tempfo' ' OR pos(temp)=0; 
if temp|=' • then goto 1; x:* ^(ten?)- see.K(teNp)- 
for x:=l to x do begin 
write (output ,tempf) ; 
get (temp) ; 
end; 



1: 

writeln (output) ; 
end; 
end; 

procedure FillScreen( { Format and print a record } 

var output : Text; 

var table : TableFile { Possibly peripheral; so what? }; 

var data : DataFile { Almost certainly peripheral; requires 

that seek() be allowed on files which are associated with an 
external storage device and are in Inspection mode. } 

var tablentry : TableRec; 

page : Byte; 

); 
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var 

screen, field 
i, j ,base 
convert 



Text; 
Whole ; 
TypeCross; 



procedure Posit(var output , input :Text; x:SWIndex; yrSEIndex); 

{ Dynamic array example. Input's maximum size depends on whether 
it is a value or a name. Note that, in contrast to the con- 
formant array, a file argument can be packed (Text = packed 
file of char), but it cannot be passed by value, since allowing 
files to be assignment-compatible would create an ambiguity 
either of whose resolutions contains a paradox. Oh well, such 
are the breaks . . . } 
begin 

seek (output ,y*30+x) { Note that an end-of-line, in conformance 
to the standard, is assumed to occupy one sequence in the 
file. Some ASCII computers use the old-fashioned chr(13)~ 
chr(10) terminator instead of the ANSI-standard chr(10). 
Some computers have weird character sets that require escapes 
to enable certain subsets. Many EBCDIC computers derive eoln 
from (file-position MOD record-length). Such difficulties 
may force some implementations to prohibit the use of seek() 
on externally-associated textfiles and to use special-case 
Direct-mode-only code in all the file-handling procedures 
to produce extra-wide characters with special bits to indicate 
prefixes. Ugh. As I have suggested, my extension simplifies 
the programmer' s job at the expense of creating double the work- 
load for the run-time library. But anyone afraid of a little 
inefficiency should use an assembler — or a better computer!}; 
reset (input) ; 

while NOT eof (input) do begin 
write (output, inputf) ; 
get (input) ; 
end ; 
end; 

begin { FillScreen } 
init (screen) ; 

for i:=l to ScreenHeight do writeln (screen,' ' :ScreenWidth) ; 
base :=pos (data) { Assume data file already positioned }; 
with tablentry, convert do begin 
seek (table, fd) ; 
for i:=l to nent do begin 

with tablef do if p=page then begin 
seek (data, base+loc) ; 

for j:=l to leng do read (data, xval [j] ) ; 
for j:=leng+l to MaxField do xval [j] :=' *' ; 
case ft of 

A : Format(field,aval,af ,vl) j 
Bl : Format (field, blval,0 ,vl) ; 
B2 : Format(f ield,b2val,0,vl) ; 
B4 : Format (f ield, b4val, 0, vl) ; 
D : FormatDate(field,dval) ; 
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X : write (field, xvalrvl) ; 
end; 
Posit (screen, field, vx,vy) ; 
init (field) ; 

write (field , name :nl,' (• ,fx:l," )' ); 
Posit (screen,field,nx, ny) ; 
end; 
get (table); 
end; 
end; 
Dump (output, screen) ; 
end; 

begin { MoneyMarketlll } 
lnl0:=ln(10.0); 
{ Determine filnum } 
dread (table, f ilnum,f ilcon) ; 

connect (data, fi Icon. name) \. external is standard, why not connect? }; 
reset (data) { Requires random-I/O ability in run-time environment }; 
{ Position datafile and determine page } 

FillScreen (output, table,data,filnum,page,ScreenHeight,ScreenWidth) ; 
{ Other processing } 
end. 

7. Optional St ring Functions. 

The main point of this essay (whenever it pretended to have one) 
has been that Pascal has always had string-handling ability and that 
the addition of a few functions could provide enough improvement to 
obviate any need for a heavyweight boxing match to decide which dynamic 
array description method should be used. However, the example program 
is in many ways redundant, since the same kinds of code sequences 
appear repeatedly. For this reason the following suggested list of 
string functions is proposed. Implementing them in assembly would 
remove the restriction that the files must be of a specific type. 
The "type" File, as used below, reflects this generic capability, 
available only to intrinsic procedures. 

procedure Append(var output, input:File) ; 
begin 

reset (input) ; 

while NOT eof (input) do begin 
write (output, inputf) ; 
get (input); 
end; 
end; 



procedure Copy (var output, inputrFile) ; 
begin 

init (output) ; 

Append (output, input) ; 

end; 



8-Sep-81 



Yet Another Extension 



procedure Posit(var output, input:File; sequence: Integer) ; 
begin 

seek (output, sequence) ; 
Append (output, input) ; 
end; 

procedure Switch (var output, input:File) ; 
begin 

Copy (output, input) ; 

init (input) ] Actually, since the internal pointers are ^eing 

switched, the input file would be left undefined (closed). } 
end; 

procedure Extract(var input, output:File; loc,leng : Integer) ; 
var x: Integer; 
begin 

seek (input, loc) ; 
init (output) ; 
for x:=l to leng do begin 
write (output, inpuff) ; 
get (input) ; 
end; 
end; 

procedure Insert(var output, input:File; sequence: Integer) ; 
var 

temp : File; 
x : Integer; 
begin 

Extract (output, temp, 0, sequence) ; 
Append (temp, input) ; 
while NOT eof (output) do begin 
write (temp, outputf) ; 
get (output) ; 
end; 
Copy (output, temp) ; 
end; 

function Compare (var lef t,right:File) :1. .3; 
label 1; 
begin 

reset (left) ; 

reset (right) ; 

1: 

if eof(left) then Compare :*3-ord (eof (right) ) 

else if eof (right) then Compare :=l+ord (eof (lef t) ) 

else if leftjorightt then Compare :=l+2*ord( lef tf<rig)r tj ) 

else begin 

get (left) ; 

get (right) ; 

goto 1 ; 

end; 
end; 
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Function Locate (var parent, searchrFiie) : Integer ; 

Pre-assertions : parent. M=Direct; parent. Pos is starting point. 
Post-assertions: parent. Pos=Locate+length (search) } 

Locate is assigned the parent sequence number of the first element 
of search (starting the search from the input value of 
parent. Pos). If the search file cannot be found in parent, Locate 
is returned as length (parent) . This definition avoids special- 
case handling both within Locate and in the calling code. Compare 
this simplicity to the definition and use of DEC s BASIC ins tr /pos 
function! } 

label 1,2; 

var localroot: Integer; 

begin 

localroot :=pos (parent) ; 
while localroot<length (parent) do begin 
reset (search) ; 

if eof (search) then goto 2; 
if eof (parent) then begin 

localroot ;=length (parent) ; 

goto 2; 

end; 
if parentf=search| then begin 

get (parent) ; 

get (search) ; 

goto 1; 

end; 
localroot :=localroot+l; 
seek (parent, localroot) ; 
end; 



2: 
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Locate : =localroot ; 
end; 



BRITISH COLUMBIA HYDRO AND POWER AUTHORITY 



970 BURRARD STREET 
VANCOUVER, B.C. 
V6Z 1Y3 
TELEX 04-54395 

1981 July 21 

Dear PUG 

subject: PRETTYPRINT 

Prettyprint programs should reformat multiline comments into single 
line comments. This will help detect unmatched comment delimiters. 
It will also make it clear when bits of Pascal code are actually 
comments on how to modify the program. 



One final question: Should the first file argument of these 
string procedures be optional, as it is for the other intrinsic file 
procedures? Personally, I believe that the original file-omission 
option was a mistake, so I never use it. Allowing first-argument 
omission for the string-handling procedures would be difficult, since 
the second argument is often also a file. For these reasons, I vote 
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(* TO SUM THE INTEGERS 
for i:= 1 to 10 do *) 
a:= a+w[i]; 



(* TO SUM THE INTEGERS *) 
(* for i:= 1 to 10 do *) 
a:= a+w[i]; 



"A Comment on Comments" 
W. Cox 

GenRad/Futuredata 
17361 Armstrong Ave. 
Irvine, CA 92714 



Introduction 

While working on our Pascal compiler for the Intel 8086 (written in 
UCSD Pascal), I have studied closely several I of the User's Group software 
tools with an eye toward converting them to that dialect. I have the 
following observations to make regarding the handling of comments by 
those tools and upon the definition of a comment in the Draft Standard 
proposal 1 13. 

ISO Standard Comment Forms 

This table enumerates the four forms of comment permitted by the 
Draft Standard. 



Forms 

1 
2 
3 
4 



Starting 
Delimiter 



Ending 
Delimiter 



Note: Forms 3 § 4 are prohibited by our UCSD compiler. 



UCSD Pascal Comment Handling 

The UCSD Pascal compiler that we use (a much-modified version 1.5) 
permits Forms 1 § 2 of comments, with a most useful twist: a comment 
begun by a curly bracket can only be terminated by a cur ley bracket, and 
one begun by the "(*" digraph can only be terminated by the "*)" digraph. 
Users whose systems don't permit both forms are unaffected, but those of 
us who have cur ley bracket characters are lucky. By using only form 1 
for normal comments, we are able to "comment out" our temporarily delete 
bodies of text (using form 2) in a natural and error -free manner. 



Draft Standard Suggestion 

Since the above manner of comment handling is most useful to some of us, 
relatively cheap to implement for all of us, and invisible to those whose 
character sets don't permit it, I suggest that the Draft Standard, section 
6.1.8 paragraphy 1, sentence 1 be rewritten as follows: 

The constructs "f"..."/" and "(*"..."*)" shall be consents if the "$" 
or "(*" does not occur within a character- string. The constructs "$"... "*)" 
and "(*"..."}" are expressly forbidden. 

The note in section 6.11 should be deleted. 

Software Tools Commentary 

It is interesting that the software tools published in Pascal News 
are not uniform in their handling of comments. XREF I 47, written by Pascal's 
inventor, and ID21D £2 J follow the UCSD convention while PRETTYPRINT C 6 J 
and REFERENCER £ 3J follow the Draft Standard. FORMATTER 17J doesn't re- 
cognize cur ley brackets at all! 



References : 



A.Addyman, et al. ISO DP/7185 
Programming Language Pascal. 
Pascal News # 18 (May, 1980) 



A Draft Proposed Standard for the 



2. Andy Mickel. Recoding a Pascal Program using 1D21D. 
Pascal News #15 (September, 1979) 

3. Sale, A.H.J. User Manual - Referencer. 
Pascal News .# 17 (March, 1980) 

4. Wirth, N., et al. Cross Referencer Generator for Pascal Programs. 
Pascal News # 17 (March, 1980) 

5. Shillington $ Ackland (ed). UCSD (Mini -Micro Computer). 
Pascal Version 1.5 (January, 1980) 

Note: This reference does not discuss the UCSD comment handling; 
it is included for completeness only. 

6. Heuras § Ledgard. Pascal Prettyprinting Program. 
Pascal News # 13 (December, 1978) 

7. Condict, Marcus § Mickel. Pascal Program Formatter. 
Pascal News # 13 (December, 1978) 
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Finally, your statement that the inaccessabillty to machine 
language in some Pascals (most provide it either inline or 
via EXTERNAL routines) prevents "the Pascal user from 
effectively programming his microprocessor" leads me to 
believe that you are equating machine programming with 
effective programming. I think if you consider the 
programmer's time in coding and debugging, you will find 
Pascal - even a p-code Implementation - to be the more 
"effective". 



H em e nway As so el a t e s f 
101 Tremont Street, 
Boston MA 02108 
U.S.A. 



As a longtime user 
interested to see 



of the language Pascal I was 
*..„«* ,*<,„«« wv »» o description of your language 
HA-PASCAL/I* As I read the description, however, I becane 
concerned, and finally skeptical. While you have produced 
what will clearly be a good product and a very useful tool 
for the intended applications, I am concerned that you are 
selling a product as a Pascal language that is really not 
Pascal. (Pascal is not an acronym but a person's name, so 
it Is usually written in normal case, like Ford Motors, 
Washington or San Diego.) 

It seems to me - after read 
flyer - that your product HA 
described as PL/I with some of t 
memory references MEM and MEMW i 
of a "pseudo-variable" which 
completely alien to Pascal. Al 
(built-in or library) FUNCTIONS 
purpose - a FUNCTION to return a 
one. This is the spirit of Pasc 
not. Also, your CALL statetn 
PL/ I, not Pascal. All Pascals t 
declare external routines as 
appropriate, with the subprog 
keyword EXTERNAL (or EXTERN in a 
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Perhaps more importantly, your advertising makes no 
reference to the existence of the RECORD construct. The 
RECORD concept is one of the key concepts of Pascal; one of 
the things that makes Pascal Pascal. A Pascal without 
RECORDS is like a computer without a CPU r like a car without 
w h e el s . 



I am bringing these problems to your attention to help 
prevent a situation in which people using your product think 
they are using Pascal, and try to move programs to a Pascal 
compiler and blame Pascal for not being your language. To 
be honest with your customers current and potential, you 
might choose to refer to HA-PASCAL/I as "a Pascal derivative 
for microcomputer systems programming" - which it is 
rather than "a version of Pascal" - which I don't think it 
is. 

Thank you. 



Sincerely, 



r/U. 



Ian F. Darwin 

University of Toronto Computing Services 

10 King's College Road 

Toronto, Ontario M5S 1A1 

/maklet/tik 

CC: 

T. Wood 
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July 9, 1981 



Mr. Rick Shaw 
Pascal Users Group 
P.O. Box 88524 
Atlanta, GA 30338 



Dear Mr. Shaw: 

I am interested in joining the Pascal Users Group. 
Please send information and the necessary materials. 

I am an independent contractor who has recently com- 
pleted a Pascal-in-ROM for the Rockwell AIM 65; I 
expect Rockwell to release the ROMs this month. The 
noteworthy thing about this software is that it relates 
to the user like BASIC: there is no compilation phase 
requiring external file storage; it talks to the user 
entirely at the source- language level, including a 
source-level trace, source-level single-step, and 
immediate statement execution; and execution is possible 
right after a source-level change. 

The AIM 65 version of the Instant Pascal (my trademark) 
design implements a substantial subset of the language, 
including character, string (an extension), real, enum- 
erated, subrange, array, and record data types, as 
well as all statement forms. 

Now that the product is real I am ready to start talking 
with people who see other uses for this technology, 
particularly those who are in a position to support 
its development. Fuller versions of this software 
for other microcomputers come to mind, as well as 
more specific tools, such as microprocessor software 
development systems. Your assistance in getting the 
word out will be appreciated. 

Thanks for your help. 



Very/9ruly yours, 

Melvin E. Conwa 

_ 8 BROOK HEAD AVE., BEVERLY, MASS. 01915 U.S.A. PHONE (617) 922-5042 




1 DEC 1981 



RICK SHAW 

PASCAL USER'S GROUP 

DIGITAL EQUIPMENT CORPORATION 

5775 PEACHTREE DUNWOODY RD. 

ATLANTA, GEORGIA 30342 



Dear Rick, 

I found your address in the back of " Introduction to Pascal for 
Scientists" by James W. Cooper and so am writing to join the PUG. 

I have for the last month owned an APPLE II w/48K, a PASCAL language 
card, an 80 column card, two disk drives, an Epson MX— BO printer, and 
a D.C. Hayes Micromodem. The purpose of all this equipment is to 
allow use of the PASCAL text editor as a word processor and to 
communicate my texts with a group of coworkers scattered all across 
the USA. It has worked well and I now fancy myself as a demon 
editor, however as a PASCAL programmer, a novice only. A program to 
select printer options— menu sort of things has been the extent of 
my programs. 

The need for more information is clearly apparent as I have no other 
programming background to draw from so I am inclosing a few extra 
dollars (I hope, as I don't know exactly what the fee for joining is) 
for back issues of PASCAL NEWS- particularly those issues which have 
information about programs for ..storage and retrieval of 
files. .storage and retrieval of addresses and print out of 
same. .fast Fourier transforms. . and most important when writing a 
letter how do I get the 6D printer to page? 

Thanks for whatever time you can spare to help me out. 



Regards 



k 




MARVIN SULLIVAN 
814 BOCA CIEGA ISLE 
ST. PETERSBURG BEACH 
FL 33706 
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Three Rivers 
Computer Corporation 
195 Farmington Avenue 
Farmington Connecticut 06032 
203/674-8367 



September 24, 1981 






Pascal User Group 
P. 0. Box 888524 
Atlanta, GA 30338 

Attn: Rick Shaw 



Dear Rick, 



It was good talking with you last night. I would appreciate you 
placing the following text in your newsletter: 

We would appreciate contact from anyone utilizing Pascal under 
a VAX/VMS. We are specifically interested in the run-time 
efficiency of executable code. Any other comments would be 
appreciated. Please Contact: 

Jim Corrigan 

TRW Inc. 

5205 Leesburg Pk. (Suite 1106) 

Falls Church, VA 22041 



(703) 931-2017 



Thanks again, Rick. 



Yours truly, 

Jim Corrigan 
TRW, Inc. 



October 28, 1981 



Pascal User's Group 

P.O. Box 4406 

All en town, PA 18170 

RE: Rush Request for Software Package Information 

Dear Sir or Madame: 

I have the responsibility of identifying "all" of the available software 
products and packages written in PASCAL. As you are aware, this is a very 
large task, and I have a very short time to acquire as much information as 
possible— about two weeks. 

I need your help, and the help of as many people as you can contact. There 
is a benefit to at least some respondents. As you may know, our company 
produces a high-speed unshared computer (PERQ) which is a Pascal -based 
machine. We are looking for purchase, contract, OEM, third party and 
contributed or public domain applications and any other Pascal software. 
We will be negotiating distribution and license agreements immediately 
with qualified software sources. 

Can you please assist me by: 1) forwarding any present compilations 

or catalogues you have of available software, to me immediately; 2) passing 

on this request to any other appropriate parties, by phone, if possible. 

I greatly appreciate any information you can provide. Please feel free to 
contact me anytime at (203) 674-8367. Thank you. I shall look forward to 
hearing from you. 
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DEFENSE AND SPACE SYSTEMS GROUP OF TRW INC. 

SKYLINE OFFICE' 5205 LEESBURG PIKE. SUITE 1106, FALLS CHURCH, VIRGINIA 22041 • ( 703) 931-2010. 931-2017 



Council for Educational Technology 

* Devonshire Street, London WIN 2BA Ttltphoru: 01-1536 4186 Chairman: Professor J C West, cbe Director: G Hubbard 
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3rd December 1981 



The Burleigh Centre 
Wellfield Road 
HATFIELD 
Herts. ALIO OBZ 

Tel : Hatfield 74497 



Dear Hick 

C£T TaESQTFKARE PROJECT 

■{">" • ■"•'"' • ■■ - ■ ■ ■ ■■ ■ .. « ..■■ ;■ ■ - - . - ■ 

Thank you for your letter of 1 9th November, 
earlier. 



I am sorry I have not replied 



Although all our current programs are in BASIC, our format was intended to 
be independent of language. We would like to distribute programs in other 
languages, including PASCAL, but on looking into the question, there appear 
to he a few problems which need to be sorted out first. 

Firstly, there are a few characters used in PASCAL not covered by our format 
recommendations* I hope you have now received your copy of the 
recommendations and we would, of course, be interested in any comments from 
members of PUG. 

Secondly, as you know, our telesoftware system at present is only available 
for «se with the 380X. Although PASCAL can be obtained for the 380Z, it 
will only wor* on S6K full disc machines with 80 character display. 

Thirdly, it appears that very few Computer Assisted Learning programs have 
so far heen written in PASCAL. 

In view of these problems, it is likely that in the immediate future only a 
few people would be able to obtain PASCAL by telesoftware and find it useful. 
I therefore dp not think PASCAL can be one of our first priorities, and we 
would tnot consider including programs in our library for a few months until 
our telesoftware service is fully established. 

Thank you for your interest. 

Yours sincerely 
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♦♦♦ Coulter Electronics, Inc* 

GENERAL OFFICE • 590 WEST 20tt» STREET • HIALEAH, FL 33010 • PHONE: 305:885*0131 



PASCAL USERS GROUP 
C/O RICK SHAW 
BOX 88524 
ATLANTA, GA* 30338 

.DEAR RICK, 

I have spoken with the sales people at Microsoft In an 
attempt to purchase a copy of their new release of Pascal to run 
on CP/M* They told Me that they were not selling to end users at 
this, ti«e only to OEM* They also would not reveal the .names of 
any of their OEM users but that if I could locate one Maybe one 
would sell to we* Would you, Mr, Shaw, be able to refer Me to any 
Manufacturers who are using Microsoft Pascal and who hopefully 
would consider selling to an end user* 

The Main reason I want Microsoft Pascal is the conpatlbilits 
of their object file fornat to Digital Research's for link and 
locate with RMAC assenbled files* If you know any other suppliers 
whose Pascal is compatible to Digits! Research's fornat please 
let Me know* 

I also would like to receive sows inf orwst ion on the Pascal 
Users Group* 

Thank you for your tine* Any help will be appreciated* 
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NOVCI KObOtiCS 262 Prestige Park Road, East Hartford, CT 06108 (203) 528-7133 



September 24, 1981 



Rick Shaw 

Pascal Users Group 
P0 Box 888524 
Atlanta, GA 30338 

Dear Rick: 

Nova Robotics is a new user of the Oregon Software OMSI Pascal -2, 
and we are interested in what the Pascal Users Group has to offer 
We have the OMSI Pascal on a POP 11/34 running . RSX-MM V3.2. Enclosed 
is our check for a one-year subscription. 

We are also interested in knowing if any member of the Users Group 
is developing a Pascal compiler or cross-compiler for Intel's 8086/87, 
We have talked to Oregon Software. They currently have no ptans and 
suggested we contact the Users Group. Any information you could 
supply would be appreciated. 

Sincerely, 

NOVA ROBOTICS LIMITED PARTNERSHIP 

Linda J. Phi Hips 

Manager of Software Engineering 

LJP/rsh 
Enclosures 



To the editor: 

Members of the Pascal Users Group may obtain a free copy of our 
new publication, Pascal Market News, by writing to me at the address below. 
Our publication is commercially slanted towards buyers and makers of Pascal 
hardware and software. Anyone requesting a free issue should be sure to 
indicate that he or she is a P. U. G. member. 

Ray Jordan 
Southwater Corp. 
P Box 5314 
Mt. Garmel CT 06518 



Rick, 

A couple of items! 

1. Pascal News continues to be outstanding! You took over a big task 
from Andy* and have done a super Job. Please renew my subscription for 
three Years. (Any possibility of PUG offering a lifetime membership for 
an appropriate fee?) 




Uk chose Pascal because of tr-ansportabi 1 i tv» structure* and ease of code 
maintenance- Except for operating system interfaces and machine-dependent 
r>.".. ' inesi the total system will be written in Pascal. It will be developed 
and maintained as one system* configurable for any of the mainframes. 

I would be interested in hearing from any PUG members who have worked on 
similar large projects in Pascal. 



yincerel 



<%* 



Mike Burgher 

928 Wright Avenue #903 

Mt. View* CA 94043 



(day) 408-744-5673 



E0I ENCOUNTERED. 



Implementation Notes 



■ JET PROPULSION 



JET PROPULSION LABORATORY California Institute of Technology 4800 Oak Grove Drive, Pasadena, California 91103 



TO: Distribution 

FROM: E. N. Miya 

SUBJECT: Suite Report for University of Wisconsin Pascal on Univac 1100 



Attached you will find the Validation Suite Report for the UW Pascal 
compiler on the Univac 1100. Sorry we could not get it to you sooner, 
it spent some time in our documentation section getting approval. 

Please keep us informed about the progress of version 3.0 of the Suite. 



Distribution: 

R. J. Cichelli 

B. Dietrich 

A. H. J. Sale 

R. Shaw^ 



PASCAL VALIDIATION SUITE REPORT 



Authored by: 



I.E. Johnson, E.N. Miya, S.K. Skedzieleweski 
Pascal Processor Identification 



Computer: Univac 1100/81 

Processor: University of Wisconsin Pascal version 3.0 release A 

Test Conditions 

Testers: I.E. Johnson, E.N. Miya. 

Date: April 1980 

Validation Suite Version: 2.2 

General Introduction to the UW Implementation 

The UW Pascal compiler has been developed by Prof. Charles N. 
Fischer. The first work was done using the P4 compiler from 
Trondheim, then the NOSC Pascal compiler written by Mike Ball was 
used, and now all development is done using the UW Pascal com- 
piler. 

There are two UW Pascal compilers; one produces relocatable code 
and has external compilation features, while the other is a 
"load-and-go" compiler, which is cheaper for small programs. 
Most tests were run on the "load-and-go" version. Both compilers 
are 1-pass and do local, but not global optimization. The UW 
compiler is tenacious and will try to execute a program contain- 
ing compile-time errors. This causes problems when running the 
Validation Suite, since programs that are designed to fail at 
compile time will appear to have executed. 



Conformance Tests 
Number of Tests Passed: 
Number of Tests Failed: 

Details of Failed Tests 



123 
16 



Test 6.4.3.5-1 failed on the declaration of an external 
file of pointers (only internal files of pointers are 
permitted) . 

Tests 6.4.3.5-2, 6.4.3.5-3 and 6.9.1-1 failed due to an 
operating system "feature" which returns extra blanks at 
the end of a line. This problem affects EOLN detection. 

Test 6.5.1-1 failed because the implementation prohibits 



Telephone (213) 354-4321 



Twx 910-588-3269 



Twx 910-588-3294 



The research described in this paper was carried out at the Jet Propulsion 
Laboratory, California Institute of Technology, under NASA Contract NAS7-100. 



files that contain files. 

Tests 6.6.3.1-5 and 6.6.3.4-2 failed because the current 
version of this implementation prohibits passing standard 
functions and procedures as parameters. 

Test 6.6.5.3-1 failed to assign an already locked tag 
field in a variant record, but the standard disallows 
such an assignment! (Error in test?) 

Test 6.6.5.4-1 failed to pack because of a subscript out 
of range. MACC notified. 

Test 6.6.6.2-3 failed a nine-digit exp comparison. 
Univac uses 8 digit floating point. 

Test 6.6.6.5-2 failed test of ODD function (error with 
negative numbers) . 

Test 6.8.2.4-1 failed because non-local GOTO statements 
are not allowed by this implementation. 

Test 6.8.3.4-1 failed to compile the "dangling else" 
statement, giving an erroneous syntax error. 

Tests 6.9.4-1 and 6.9.4-4 failed do unrecoverable I/O er- 
ror. Problem referred to MACC. 

Test 6.9.4-7 failed to write boolean correctly. UW 
right-justifies each boolean in its field; the proposed 
ISO standard requires left-justification. 

Extensions 

Number of Tests Run: 1 

Details of Tests 

Test 6.8.3.5-14 shows that an OTHERWISE clause has been 
implemented in the case stetement. 



Deviance Tests 

Number of Deviations Correctly Handled: 77 
Number of Deviations Incorrectly Handled: 14 
Number of Tests Showing True Extensions: 2 
Details of Extensions 



Test 6.1.5-6 shows that a lower case e may be used in 
real numbers. 



Test 6.1.7-11 shows that a null string is accepted by 
this implementation. 

Details of Incorrect Deviations 

Tests 6.2.2-4, 6.3-6, 6.4.1-3 show errors in name scope. 
Global values of constants are used even though a local 
definition follows; this should cause a compile-time er- 
ror. 

Tests 6.4.5-3, 6.4.5-5 and 6.4.5-13 show that the imple- 
mentation considers types that resolve to the same type 
to be "equivalent" and can be passed interchangeably to a 
procedure. 

Test 6.6.2-5 shows a function declaration without an as- 
signment to the function identifier. 

Test 6.8.3.9-4 the for-loop control variable can be modi- 
fied by a procedure called within the loop. No error 
found by implementation. 

Tests 6.8.3.9-9, 6.8.3.9-13 and 6.8.3.9-14 show that a 
non-local variable can be used as a for-loop control 
variable. 

Test 6.9.4-9 shows that a negative field width parameter 
in a write statement is accepted. It is mapped to zero. 

Test 6.10-1 shows that the implementation substitutes the 
default file OUTPUT in the program header. No error mes- 
sage. 

Test 6.10-4 shows that the implementation substitutes the 
existence of the program statement. We know that the 
compiler searched first but found source text (error 
correction) . 

Tests 6.1.8-5 and 6.6.3.1-4 appear to execute; this oc- 
cured after the error corrector made the obvious changes. 



Error Handl ing 

Number of Errors Correctly Detected: 

Number of Error Not Detected: 

Details of Errors Not Detected 



29 

17 



Tests 6.2.1-7, 6.4.3.3-6, 6.4.3.3-7, 6.4.3.3-8 and 
6.4.3.3-12 show that the use of an uninitialized variable 
is not detected. Variant record fields are not invali- 
dated when the tag changes. 6.4.3.3-12 incorrectly 
printed "PASS" when it should have printed "ERROR NOT 
DETECTED". 



Test 6.6.2-6 shows the implementation does not detect 
that a function identifier has not been assigned a value 
within the function. The function should be undefined. 
The quality of the test could be improved by writing the 
value of CIRCiERADIUS. 

Test 6.6.5.2-2 again runs into the EOLN problem. 

Test 6.6.5.2-6 shows that the implementation fails to 
detect the change in value of a buffer variable when used 
as a global variable while its dereferenced value is 
passed as a value parameter. This sould not cause an er- 
ror, and none was flagged. However, when the char was 
changed to a var parameter no error was detected, either. 

Test 6.6.5.2-7 shows that the implementation fails to 
detect the change in a file pointer while the file 
pointer is in use in a with statement. This is noted in 
the implementation notes. 

Test 6.6.5.3-5 shows the implementation failed to detect 
a dispose error; but again, the parameter was passed by 
value, not by reference! (Error in test) 

Tests 6.6.5.3-7 and 6.6.5.3-9 show that the implementa- 
tion failed to detect an error in the use of a pointer 
variable that was allocated with explicit tag values. 

Tests 6.6.6.3-2 and 6.6.6.3-3 show that trunc or round of 
some real values. 2**36 does not cause a run time error 
or warning. In those cases, the value returned was nega- 
tive. Error reported to MACC. 

Tests 6.7.2.2-6 and 6.7.2.2-7 show that the implementa- 
tion failed to detect integer overflow. 

Tests 6.8.3.9-5 and 6.8.3.9-6 show that the implementa- 
tion does not invalidate the value of a for-loop control 
variable after the execution of the for-loop. Value of 
the variable is equal to the last value in the loop. 
These tests could be improved by writing the value of m. 



Im pi em en t at i o n Defined 
Number of Tests Run: 



15 



Number of Tests Incorrectly Handled: 

Pe tails of Im pi ement at i on definitions 

s h o ws m ax in t e qua 1 s 



34359738367 
Test 6.4.3.4-2 shows that a set of char is allowed. 



Test 6.4.2.2-7 
(2**35-1). 



Test 6.4.3.4-4 shows that 144 elements are allowed in a 
set, and that all ordinals must be >= and <= 14 3. 

Test 6.6.6.1-1 shows that neither declared nor standard 
functions and procedures (nor Assembler routines) be 
passed as parameters. 

Test 6.6.6.2-11 details a number of machine characteris- 
tics such as 

XMIN « Smallest Positive Floating Pt # = 1 . 4693679E-39 

XMAX « Largest Positive Floating Pt # = 1 . 70141 18E+38 

Tests 6.7.2.3-2 and 6.7.2.3-3 show that boolean expres- 
sions are fully evaluated. 

Tests 6.8.2.2-1 and 6.8.2.2-2 show that expressions are 
evaluated before variable selection in assignment state- 
ments. 

Test 6.9.4-5 shows that the output format for the ex- 
ponent part of real number is 2 digits. Test 6.9.4-11 
shows that the implementation defined default values are: 

integers : 12 characters 

boolean : 12 characters 

reals : 12 characters 

Test 6.10-2 shows that a rewrite to the standard file 
output is not permitted. 

Tests 6.11-1, 6.11-2, and 6.11-3 show that the alterna- 
tive comment delimiter symbols have been implemented; 
all other alternative symbols and notations have not been 
implemented. In addition, it is interesting that the 
compiler's error correction correctly substituted "[" for 
"(." and ":=" for "% = " as well as a number of faulty sub- 
stitutions. 



Qua I ity Measurement 
Number of Tests Runs: 
Number of Tests Incorrectly Handled: 
Results of Tests 



23 
2 



Test 5.2.2-1 shows that the implementation was unable to 
distinguish very long identifiers (27 characters) . Test 
6.1.3-3 shows that the implementation uses up to 20 char- 
acters in distinguishing identifiers. 

Test 6.1.8-4 shows that the implementation can detect the 
presence of possible unclosed comments (with a warning) . 
Statements enclosed by such comments are not compiled. 



Tests 6.2*1-8, 6.2.1-9 , and 6.5.1-2 show that large 
lists of declarations may be made in a block {Types, la- 
bels, and var) . 

Test 6.4.3.2-4 attempts to declare an array index range 
of "integer". The declaration seems to be accepted, but 
when the array is accessed (All[maxint] ) , an internal er- 
ror occurs. 



Test 6.4.3.3-9 shows that the variant fields of a 
occupy the same space, using the declared order. 



record 



Test 6.4.3.4-5 .(Marshall's algorithm) took 0.1356 seconds 
CPU time and 730 unpacked < 36 -bit) words on a Univac 
1100/81. 

Test 6.6.1-7 shows that procedures may not be nested to a 
depth greater than 7 due to implementation restriction. 
An anomolous error message occurred when the fifteenth 
procedure declaration was encountered; the message "Logi- 
cal end of program reached before physical end" was is- 
sued at that time, but a message at the end of the pro- 
gram said "parse stack overflow". 

Tests 6.6.6.2-6, 6.6.6.2-7, 6.6.6.2-8, 6.6.6.2-9, and 
6.6.6.2-10 tested the sqrt, a tan, exp, sin/cos, and In 
functions. All tests ran, however, typical implmentation 
answers (which use the Univac standard assembler 
routines) were slightly smaller than Suite computed. Er- 
ror typically occurred around the 8th digit (Univac 
floating-point precision limit) . 

Test 6.7.2.2-4 The inscrutable message "inconsistent 
division into negative operands'' appears. We think it 
means that I MOD 2 is NOT equal to I - I d iv 2 * 2. 
Problem reported to MACC. 

Test 6.8.3.5-2 shows that case constants must be in the 
same range as the case-index. 

Test 6.8.3.5-8 shows that a very large case statement is 
not permissible (>=256 selections). A semantic stack 
overflow occurred after 109 labels. 

Test 6.8.3.5-18 shows the undefined state is the previous 
state at the end of the for-loop. The range is checked. 

Test 6.8.3.9-20 shows for-loops may be nested to a depth 
of ,6. 

Test 6.8.3.10-7 shows with-loops may be nested to a depth 
of 7. 

Test 6.9.4-10 shows that the output buffer is flushed at 
the end of a program. 



Test 6.9.4-14 shows that recursive I/O is permitted using 
the same file. 

Concluding Comments 

The general breakdown of errors is as follows: 

I/O 

These problems are intimately tied to the EXEC 1100 operat- 
ing system and its penchant to pad blanks on the end of a 
line. There is no plan to try to correct this problem. 
Does an external file of pointers make sense! 

Changes in the standard 

Jensen and Wirth (second edition) was used as the standard 
for development of this compiler. Since there are 
discrepencies between it and the ISO proposed standard, 
several deviations occured. The compiler will be brought 
into conformance on most of these errors when some standard 
is adopted. 

Restrictions 

Some restrictions will be kept, even after a standard is 
adopted. GOTO's out of procedures will probably never be 
implemented, but STOP and ABORT statements have been added 
to the language to alleviate the problem. 

Bugs 

Several previously unknown bugs were found by running the 
validation suite. Professor Fischer has been notified, and 
corrections should be included in the next release of the 
compilers. 

One area that should be emphasized is the clarity of the diagnos- 
tics produced by the compiler. All diagnostics are self- 
explanatory, even to the extent of saying "NOT YOUR FAULT" when 
an internal compiler error is detected. A complete scalar walk- 
back is produced whenever a fatal error occurs. The compiler at- 
tempts error correction and generally does a very good job of 
getting the program into execution. 

The relocatable compiler has extensive external compilation 
features. A program compiled using these facilities receives the 
same compile-time diagnostics as if it were compiled in one 
piece. 



IMPLEMENTATION DESCRIPTION. 
DEC- 10 , DEC-20 (LOTS) PASCAL/PASSGO at LOTS 



1 . DISTRIBUTOR/IMPLEMENTOR/MAINTAINER: 

D 1 str 1 bu tor/Ma Intalner: 

J. Q. Johnson 
LOTS Computer Facility 
Stanford University 
Stanford, CA 94385 



(415)497-3214 



Arpanet: 

Admin. JQJGSJ-SCORE 



Imp 1 erne n tor /Maintainor: 

Armando R. Rodriguez 
Computer Science Department 
Stanford University 
Stanford, CA 94385 

2. MACHINE: Digital Equipment Corp. DEC-18 and DEC-28. 

3. SYSTEM CONFIGURATION: DEC TOPS- 18, TOPS-28; TENEX and WAITS nitors, 

using Concise Command Language (CCL). Uses KA-18 instruction set. 
Modifications for KI-18 improved inst. set, under development. 

4. DISTRIBUTION: 

+ Nondisclosure agreement required. See accompanying form. 
(*We require this with two purposes: 

a) To know how many copies are around, and who has them. 

b) To prevent the use of our Improvements by profit-oriented 

organizations in products that would later be sold.*) 
+ You should provide the transport medium. Methods used until now: 

- Through the Arpanet. 

- You send us a 9 track tape (no less than 1288 feet, 

please). Specify density and format desired, 
(default: 1688 bpl, DUMPER/BACKUP INTERCHANGE ormat). 

- You come by and get it on your tape. 

+ Distributed on an "as Is" basis. Bug reports are encouraged and 
we will try to fix them and notify you as soon as possible. 

♦ The compiler 1s going through la continual, although slow, 

Improvement process. Users, and PUG, will be notified of major 
new releases and critical bugs. 

5. DOCUMENTATION: 

♦ A modified version of the machine-retrievable manual from the 

original Hamburg package, as a complement to Jensen & Wirth. 

♦ A "help" file for online access to the most relevant topics. 
+ A NOTES file with comments and hints from local users. 

♦ An Implementation checklist. 

+ A description of interesting parts of the Internal policies 
(Packing mechanism, linkage conventions, the symbol table, a 
complete list of error messages, and a checklist to add 
predefined procedures). 

+ All the documentation machine-retrievable. 

6. MAINTENANCE POLICY: 

+ We are our own main user: maintenance benefits us first. 

♦ No guaranteed reply-time. 

♦ One to four releases a year, for the next two years, at least. 



+ Future Plans: 

- Support full Standard Pascal 

- Optional flagging of use of non-standard features. 

- Sets of any size (probably 144-element sets first) 

- CHAR going from space to * }' . 

- Make the heap a real heap. 

- 28-native version. 

- A more friendly user interface: Improvements in the 

debugger, more and better utility programs, more 
measurement tools; better error messages. 

7. STANDARD: 

+' It supports the standard as defined in Jensen & Wirth, except: 

- Records, Arrays and Files of Files are not supported. 

- Read and Write to non-text Files are not supported. 

- Set expressions that contain a range delimited by variables 

or expressions are not supported. 

- The heap works as a stack. Procedure DISPOSE 'pops' the given 

item and everything else that was created afterwards. 
+ Set size 1s 72 elements, set origin is zero. 
+ Type CHAR Includes only from space to underbar. No lower case. 
+ EXTENSIONS: Type ASCII; functions FIRST, LAST, UPPERBOUND, 

LOWERBOUND for scalars and arrays, respectively; MIN and MAX; 

separately compiled procedures; a string manipulation package; 

LOOP-EXIT construct; OTHERWISE in CASE statements; 

Initialization procedures; DATE, TIME, REALTIME. 



8. MEASUREMENTS: 

12888+ lines of PASCAL code, 598,888+ chars including comments. 
COMPILATION SPEED: around 13,888 chars/sec of CPU time on a 2858. 
EXECUTION SPEED: as good as that of the non-optimized FORTRAN 

compiler. 
COMPILATION SPACE: the compiler takes 58k of upper segment, and 

can work with 16k lower segment. 
You receive two compilers (hence the name). They support exactly 
the same language and features, but one of them (PASSGO) p oduces 
the code incore, which saves 25% CPU time and a lot of I/O in the 
compile-load-and-go sequence. This is ideal for development, and 
particularly helpful in a student environment. 

9. RELIABLILITY: Very good. It is very heavily used at LOTS (the proof *n 

that runs the most, after the editor). Implemented at 38+ sites. 

18. DEVELOPMENT METHOD: We started with the Hamburg-76 compiler, 
distributed by DECUS, which is a very good compiler itself. We 
have been cleaning bugs, adding missing parts of the standard, and 
adding features in the last 18 months. 

11. LIBRARY SUPPORT AND OTHER FEATURES: 

+ Only the essential runtime routines are written in MACRO: 

most of the library is written in PASCAL. 
+ Access to the FORTRAN library support. 
+ Access to external FORTRAN and MACRO routines. 
+ Separate compilation. 
+ Symbolic Post-mortem dump. 

+ Interactive runtime source- level debugging package. 
+ PCREF, a cross-referencer derived from Hamburg's CROSS. 
+ PFORM, a pre ttypr inter. 
+ Statement counts. 



Rational Data Systems 



Rational Data Systems 



PASCAL VALIDATION SUITE REPORT 



Pascal Users Group 

c/o Rick Shaw 

Digital Equipment Corporation 

5775 Peachtreee Dunwoody Road 

Atlanta, Georgia 30342 



Processor Identification 
Computer : 



Processor: 



Data General Eclipse 
AOS operating system 

Rational Data Systems Pascal 
AOS version, release 2.10 



(Implementations for Nova and microNova under RDOS, DOS and MP/OS 
operating systems are functionally equivalent but were not tested.) 



Dear Rick, 

Enclosed is a copy of the report of the Validation Suite (2.2) 
for our Pascal implementations on Data General machines. 

Please let me know if you need any further information for 
publication of this report in Pascal News. 




Presi 



R. Kaye 



DRK/nec 
enclosure 



Test Conditions 

Tester: Rational Data Systems 
Validation Suite Version: 2.2 

General Notes 



Several tests contained statements of the form "read (f, a[i])% where 
"f" is a textfile and "a" is a "packed .-..„; ay [l..<n>] of char". In RDS 
Pascal, the rule that 

components of variables of «;; 

packed shall not be used 3 

parameters ^ 

is applied to "read" and "rea^ln" 
and functions. Statements rejec 



fc'/'oe designated 
,.,._ variable 
*) 

1 j. as to user-written procedures 
hj the compiler were changed to the 



form "read (f, xx) ; a[i] := xx", where "xx" is of type "char" 

Some tests were not valid because they used 'structural' type 
compatibility. These were revised accordingly for 'name' type 
compatibility before running. 
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GOliFORMAHCE 



Tests passed 
Tests failed 



120 
12 



(7 causes) 



Details of failed tests: 

6.1.2-3: The significance limit is eight characters 

for both identifiers and reserved words, 
6,2*2-3: Type declaration "p = A hode" is incorrectly 

handled when types named "node" are present both 

later in same scope and earlier in outer scope, 
6.4.3. 3-1, 6.4.3 ,3-3 , 6. 8. 2. 1-1 s Empty records and empty 

field lists within record variants are rejected, 
€.4.3 .3-4: Tagfield "case which: boolean" is rejected 

when "which" is a known type identifier, 
6.5.1—1: A file may not be an element of a record or 

of an array. 
6.6.3.1-5, 6.6.3.4-1, 6.6,3.4-2, 6.6.3,5-1: Procedural 

and functional parameters are not supported. 
6.6.5.3-2: Standard procedure "dispose" is not supported. 

(Implementation planned for release 2 .20) . 



Details of erroneous tests: 

6.1*8-3: Latest draft standard defines "(*" as exactly 

equivalent to "{", "*)" exactly equivalent to "}". 

6.6.5.2-3: Some operating systems distinguish "empty" 
files (length = 0} from "nonexistent* files 
(name not known), while others do not. 

6.9.4-4: Draft standard requires "write (f, 0.0:6)" to 

produce floating-point form ("0.0e+00" or similar); 
suite is testing for f ixed-point form ("0,0") , 

6.9.4-7: Latest draft standard explicitly permits 

"True" and "False" as well as "TRUE" and "FALSE" 
when Booleans are written to textf iles. 



DEVIANCE 



Tests in which deviations were correctly detected 64 
Tests showing true extensions 3 

Tests in which erroneous deviations were not detected 26 



(13 causes) 



Details of tests showing true extensions: 

6.1.7-11, 6.4.3.2-5, 6.4.5-11: Type compatibility rules for 
constant strings weakened to accommodate 
string-handling extensions. 



Details of failed tests: 

6.1,2-1: Redeclaration of "nil" permitted. 

6.2.1-5: No error message when label is declared but 

not utilized. 
6.2,2-4, 6,3-6, 6,4.1-3: If an identifier is declared in 

two nested scopes, and there is an erroneous usage 

of the identifier in the inner scope preceding the 

definition in the inner scope, the compiler does not 

detect the error. (Compare conformance test 6.2.2-3.) 
6.2.2-7: Nested functions with same name cause erroneous 

compiletime error message. 
6.4.3.3-11: Empty record rejected at compile time. 
6.4.5-2: Subranges of same base type treated as identical 

in parameter/argument case. 
6.6.2-5: Function may lack assignment statement. 
6.6.3.5-2, 6.6.3.6-2, 6.6.3.6-3, 6.6.3.6-4, 6.6.3.6-5: 

Procedural and functional parameters not supported. 
6.6.6.3-4: Integer arguments to "trunc" and "round" 

accepted. 
6.8.2.4-2, 6.8.2.4-3, 6.8.2.4-4: Tolerates illegal jumps 

(to nonactivated statement, within structured 

statement) . 
6.8.3.9-2, 6.8.3.9-3, 6.8.3.9-4, 6.8.3.9-16: Assignment 

to control variable of "for" statement allowed. 
6.8.3.9-9, 6.8.3.9-14, 6.8.3.9-19: Nonlocal control 

variable in "for" statement allowed. 
6.9.4-9: Nonpositive field width in "write" to textf ile 

allowed. 



Details of erroneous tests: 



6.1.5-6: Latest draft standard permits both "E" and 
"e" in real constants. 



EBROR HANDLING 



IMPLEMENTATION DEFINED 



Tests in which errors were correctly detected 19 
Tests showing true extensions 1 

Tests in which errors were not detected 26 



Details of test showing true extension: 



Number of tests run 



15 



(10 causes) 



6.6 .5.2-1: After a file has been opened with "reset", 
both "get" and "put" operations are allowed. 
(In fact, both operations are permitted at all 
times, regardless of how the file was opened.) 
This extension is provided to permit convenient 
random processing. RDS Pascal provides the 
ability to reposition files with the predeclared 
procedure "seek (<filename>, <integer expression^ " 
(Not permitted for files of type "text".) 



Details of erroneous tests: 

6.11-1: Alternate comment delimiters no longer belong 

to category "implementation-defined"; explicitly 
required by latest draft standard. 

6.11-2: Equivalent symbol for uparrow no longer belongs 
to category "implementation-defined"; explicitly 
required by latest draft standard. Equivalent 
symbols for colon, semicolon, assignment symbol, 
and square brackets no longer defined; deleted 
from latest draft standard. 

6.11-3: Equivalent symbols for comparison symbols not 
listed in draft standard. 



Details of failed tests: 

6.2.1-7, 6.4.3.3-6, 6.4.3.3-8, 6.5.4-1, 6.5.4-2, 
6.8.3.9-5, 6.8.3.9-6: 

No check is done at runtime for variables with 

"undefined" (uninitialized, etc.) values. 
6.4.3.3-5, 6.4.3.3-7: Storage redefinition is permitted. 
6.4.3.3-12: Empty record rejected at compile time. 
6.4.6-7, 6.4.6-8, 6.7.2.4-1: No runtime check for illegal 

set assignments. 
6.6.2-6: No runtime check for function that fails to 

execute assignment statement. 
6.6.5.2-6, 6.6.5.2-7: File may be repositioned while 

buffer is "var" parameter or is record variable 

of "with" statement. 
6.6.5.3-3, 6.6.5.3-4, 6.6.5.3-5, 6.6.5.3-6: Standard 

procedure "dispose" not supported. 
6.6.5.3-7, 6.6.5.3-8, 6.6.5.3-9: Misuse of variable 

created by variant form of "new" is tolerated. 
6.8.3.5-5, 6.8.3.5-6: No runtime error when case-index 

expression matches none of the case-constants. 
6.8.3.9-17: Nested "for" statements may have the same 

control variable. 



Details of other tests: 

6.4.2.2-7: The value of "maxint" is 32767. (But the 

value -32768 can be created by writing "-maxint-1" 
and is not rejected as erroneous.) 

6.4.3.4-2: Declaration "set of char" is permitted. 

6.4.3.4-4: Implementation permits sets to contain as many 

as 4080 elements. No set may contain negative elements; 
e.g. "set of 0..4079" is acceptable, "set of -1..4078" 
is not. This test brought to light a compiler error; 
the unacceptable declaration "set of -1..+1" was 
accepted by the compiler. However, an attempt to 
insert a negative element into a set (any set) will 
cause a runtime error. (Fixed in release 2.11). 

6.6.6.1-1: Procedural and functional parameters not supported. 



6 .6 .6. 2-11: Reals are implemented using Data General's 
standard single-precision floatingpoint format: 
sign: one bit 

exponent: 7 bits f excess-64 notation 
fraction: 24 bits (6 hexadecimal digits) 
All results are normalized (i.e. leftmost hexadecimal 
digit of fraction is always > 0) . However, the range 
of values that can be read from or written onto 
textfiles is smaller than the range of values that 
can be represented internally: conversion to/from 
ASCII is supported only for values in the range 
1.0e-75..1.0e+75. Because this test relies on 
non-detection of underflow at runtime, it could not 
be executed without extensive modification. Ultimate 
results were: 

16 
6 



6.7.2, 
6.7.2, 
6.8.2, 
6.8.2, 
6.9.4- 
6.9.4- 



3-2 

3-3 

2-1 

2-2 

5: 

11: 



beta 
t 
rnd 
ngrd 
machep 
negep 
iexp 
minexp 
maxexp 
eps 
epsneg 
xmin 
xmax 
Boolean expression 



1 

-5 
-6 
7 

-64 
63 

9.53674e-7 
5.96046e-8 
5.39760e-79 
7.23700e+75 

*a and b" is fully evaluated. 
Boolean expression "a or b M is fully evaluated. 
; Selection then evaluation for "a[i] := expr". 
i Selection then evaluation for "p* := expr". 
Two digits written in an exponent. 
Default field widths for "write" to textfiles: 
integers variable 

Booleans variable 

reals 8 characters 



QUALITY 

sssssss 

Number of tests run 



23 



Details of erroneous tests: 



6.7.2.2-4: Test of "mod" operator not in conformance 

with latest draft standard. Caused runtime error 
message "Non-positive Divisor in MOD Operation". 

6.9.4-14: Recursive 10 using same file allowed. This 
test contains a superfluous program parameter 
which caused the error message "program parameter 
not declared as file in outermost block". After 
correction of the error, it ran successfully. 



Details of other tests: 



5.2 

6.1 

6.2 
6.2 
6.4 



6.4 
6.4 



6.5 
6.6 
6.6 
6.6 



6.8 



6.8 
6.8 



6.8 
6.8 
6.9 



.2-1, 6.1.3-3: Significance limit for identifiers 

is eight characters. 
.8-4: No warning message generated when comment extends 

across several source lines. 
.1-8: Accepted 50 type declarations. 
.1-9: Accepted declaration and siting of 50 labels. 
.3.2-4: Declaration "array [integer] of integer" 

produced error message "array index may not be 

of type INTEGER". 
.3.3-9: Reverse correlation of fields in record. 
.3.4-5: This test was revised to use the RDS "time" 

extension, which is accurate only to the second. 

Procedure "Warshallsalgorithm" required 184 bytes 

of object code, and approximately 5 seconds of 

elapsed execution time (on a multi-user system) . 
.1-2: Long declarations allowed. 
.1-7: Procedure/function nesting limit is eight. 
.6.2-6 (sqrt) , 6.6.6.2-7 (arctan) , 6.6.6.2-8 (exp) , 
.6.2-9 (sin & cos), 6.6.6.2-10 (In): 

RDS personnel not trained in numerical analysis, 

unable to interpret results of these tests. 
.3.5-2: No warning message when a "case" statement 

contains an unreachable path. 
.3.5-8: Accepted large "case" statement. 
.3.9-18: After normal termination (i.e. no "goto") 

of a "for" loop, the control variable has the 

value of the limit expression. (After execution 

of "£©r i := red to pink do ;", the value of "i" 

is "pink".) 
.3.9-20: Accepted "for" statements nested 15 deep. 
.3.10-7: Nesting limit of "with" statements is 12. 
.4-10: Textfile output is flushed at end of job 

when linemarker is omitted. (Note that no 

linemarker is inserted, however*) 



EXTENSIONS 



Number of tests run 



Details: 



6.8.3.5-14: The "otherwise" clause in a "case" statement 
is not supported. (Refer to err or handling tests 
6.8.3.5-5 and 6.8.3.5-6.) 



Tot Pascal News, c/o Rick Shaw 

From* David Intersimone -■ B* Marco-Shatz Corp. 

Rtft-r Validation of Al PhaPASCAL compiler 

Here is a copy of a validation of the AiphaPASCAL compiler. I 
have eiven a few comments on the compiler and the validation suite in the 
validation report. 

I have sent a copy of the report to Prof. Sale. 

David Intersimone 



y^j.ja^*+*> it-ii fa 



De Marco-Shatz Corp. 
312 Maple Ave. 
Torrance » Ca. 90503 
(213) 533-5080 



ALPHA MICROSYSTEMS AM-IOO/T 



Pascal Validation Suite Report 

Pascal Processor Identification 

Computers Alpha Microsystems AM-iOO/T 

Processor: AiphaPASCAL V2.0 

Installation: De Marco Shatz Corporation* Torrance* Ca. » USA. 

Test Conditions 

Tested By: David Intersimone 
Date: February / March 1981 
Validation Suite Version: 2.2 



Report Sent To: 

Alpha Microsystems* Software Department* Irvine* Ca.» USA. 

Pascal News* c/o Rick Shaw* Atlanta* Ga. * USA. 

Prof. Arthur Sale* Department of Information Science* 
University of Tasmania* Hobart* Tasmania* Australia. 



'AiphaPASCAL' and 'AM-IOO/T' are trademarks of 
Alpha MicrosYstems* Irvine* Ca. » USA. 



Conformance Tests* 

Total Number of Conformance Tests: 139 

Number of Tests Passed: 105 

Number of Tests Failed: 34 (19 reasons) 

Details of Failed Conformance Tests: 



Tests 6.1.2-3, 6.3-1 8-character significance for identifiers. 

Tests 6.1.6-1, 6.1.6-2, 6.2.1-1, 6.2.1-2, 6.2.2-5, 6.8.2.4-1, 
6.8.3.7-3, 6.8.3.9-8 GOTO statements are not permitted 
without the- £*G+} compiler option. 

Test 6.2.2-3 The global type for the variable 'node' was used 

causins a mismatched type in the assignment of ptr~:=true; 

Tests 6.4.3.3-1, 6.4.3.3-3 Empty records are not allowed. 

Test 6.4.3.5-1 Only type or constant identifiers are allowed 
for file types. 

Tests 6.4.3.5-2, 6.9.1-1 EOLN and EOF are not correctly implemented. 

Test 6.5.1-1 The type of record fields and arrays cannot be a 
FILE type. 

Tests 6.6.3.1-5, 6.6.3.4-1, 6.6.3.4-2 6.6.3.5-1 procedures and 
functions passed as parameters are not allowed. 

Test 6.6.5.2-3 failed at runtime with 'invalid filename in RESET'. 

Test 6.6.5.2-5 A REWRITE of the file sets EOF false. 

Test 6.6.5.3-2 DISPOSE is not implemented. AlphaPASCAL uses 
MARK and RELEASE to recover memory allocated by NEW. 

Test 6.6.5.4-1 PACK and UNPACK are not implemented. AlphaPASCAL 
automatically unpacks packed data structures. 

Test 6.7.1-1 Operator precedence was changed for compatabil ity 
with other Alpha Micro language processors. 

Test 6.8.3.5-4 Crashed the compiler. 

Test 6.8.3.9-1 Both expressions in a 'FOR' statement are not 
evaluated before assignment is done. 

Test 6.8.3.9-7 ended up in an infinite loop showing that the 
test at the last increment caused wraparound (overflow) 
of the FOR variable. 



Test 6.9.3-1 The READLN function is not correctly implemented. 

Tests 6.9.4-3, 6.9.4-4, 6.9.5-1 It is illegal to READ into a 
packed character field. 

Test 6.9.4-7 WRITE and WRITELN do not accept a Boolean variable 
as an argument. Also, as with tests 6.9.4-3 et al , it is 
illegal to read into a packed character field. 



Deviance Tests: 



Total Number of Deviance Tests: 94 

Number of Deviations Correctly Detected: 55 

Number of Tests Not Detecting Erroneous Deviations: 25 (16 reasons) 

Number of Tests Showing True Extensions: 2 (2 reasons) 

Number of Tests Incorrectly Handled: 12 (6 reasons) 



Details of Tests Not Detecting Erroneous Deviations: 



Test 6.1.2-1 nil can be used with types other than pointers. 

Test 6.1.7-6 Strings can have bounds other that (l..n). 

Test 6.1.7-9 Cases 1-4 were accepted. Cases 5-7 rejected. 

Tests 6.2.2-4, 6.3-6, 6.4.1-3 Some scope errors are not detected. 

Test 6.3-5 Signed constants are allowed in places other than 
constant declarations. 

Test 6.4.3.2-5 Strings can a subrange of other than integers 
as an index type. 

Test 6.4.5-2, 6.4.5-3, 6.4.5-4, 6.4.5-13 Type compatibility 
is used for variables. 

Test 6.4.5-11 Operations on strings with different numbers 
of components are allowed. 

Test 6.6.2-5 Function declarations with no assignment for the 
function identifier are allowed. 

Test 6.6.6.3-4 TRUNC and ROUND will accept integer parameters. 

Test 6.7.2.2-9 The unary operator plus(+) can be applied to 
non-numeric operands. 

Tests 6.8.3.9-2, 6.8.3.9-3, 6.8.3.9-4 Assignment can be made 
to the FOR control variable. 



Tests 6.8.3.9-9. 6.8.3.9-14, 6.8.3.9-19 Non-local variables 
can be used as FOR control variables. 

Test 6.8.3.9-16 causes endless loop. FOR control variables 
can be READ. 

Test 6.9.4-9 Field width parameters^ can be zero and negative. 

Field widths zero and -1 printed the same as field width 1. 

Test 6.10-3 Shows that the standard file OUTPUT can be redefined. 
Compiled and caused a runtime error. 



Details of Tests Showing True Extensions: 



Test 6.1.7-11 null strings are allowed. 



Test 6.10-1 Default file declarations in the program heading 
are ignored. 



Details of Tests Incorrectly Handled: 



Test 6.2.1-4 caused a bad poiner reference error in the compiler.. 

Test 6.4.3.3-11 Empty records are not allowed. 

Test 6.4.5-5 Eight(3> character identifier significance. 

Test 6.6.1-6 The procedure call one(c) did not have a semicolon 
<5) at the end of statement. An error message for the 
undefined forward procedure was not printed. 

Tests 6.6.3.5-2, 6.6.3.6-2, 6.6.3.6-3, 6.6.3.6-4, 6.6.3.6-5 
Procedures and functions passed as parameters are not 
allowed. 

Tests 6.8.2.4-2, 6.8.2.4-3, 6.8.2.4-4 GOTO statements are not 
permitted without the C*G+J compiler option. 



Error Handling Tests: 



Total Number of Error Handling Tests: 46 
Number of Errors Correctly Detected: 14 
Number of Errors not Detected: 27 <16 reasons) 
Number of Tests Incorrectly Handled: 5 (2 reasons) 



Details of Errors not Detected: 



Test 6.2.1-7 Local variables have values even though they 
were never assigned. 

Tests 6.4.3.3-5, 6.4.3.3-6, 6.4.3.3-7, 6.4.3.3-8 No checking 
is done on the tag field of variant records. 

Tests 6.4.6-7, 6.4.6-8 Bounds checking is not done on 
set types. 

Test 6.6.2-6 Execution of a function without assignment of 
a value to the function variable is allowed. 

Test 6.6.5.2-2 GET when the file is at eof does not cause 
a runtime error. 

Tests 6.6.5.2-6, 6.6.5.2-7 did not cause a runtime error when 
the file position was changed while the file variable 
was in use. 

Tests 6.6.5.3-7, 6.6.5.3-8, 6.6.5.3-9 No checks are made on 
pointers when they are assigned using the variant form 
of NEW. 

Test 6.6.6.4-4 SUCC on the last value of an ordinal type does 
not cause a runtime error. 

Test 6.6.6.4-5 PRED on the first value of an ordinal type does 
not cause a runtime error. 

Test 6.6.6.4-7 CHR on a value past the limits of CHAR type does 
not cause a runtime error. 

Test 6.7.2.2-6, 6.7.2.2-7 An error does not occur when the result 
of a binary integer operation is not -maxint <= <= +maxint. 

Test 6.7.2.4-1 Overlapping sets do not cause runtime errors. 

Tests 6.8.3.5-5, 6.8.3.5-6 A runtime error does not occur when 
a CASE statement doesn't contain a constant for the value 
of the case expression. 

Tests 6.8.3.9-5, 6.8.3.9-6 A FOR control variable can be used 
without an intervening assignment. 

Test 6.8.3.9-17 Two nested FOR statements can use the same 
control variable. 



Tests 6.9.2-4, 6.9.2-5 No error occurs when reading characters 
that don't form a valid integer or real. 



Details of Tests Incorrectly Handled: 



Test 6.4.3.3-12 Empty mcoHs are not allowed. 



Tests 6.6.5.3-3* 6.6.5,3-4, 6.6.5.3-5, 6.6.5.3-6 DISPOSE 
is not implemented. 



Implementation Defined Tests: 



Total Number of Implementation Defined Tests: 15 
Number of Tests Incorrectly Handled: 4 <4 reasons) 



Details of Implementation Defined Tests: 

Test 6.4.2.2-7 WAX INT is defined as 32767. 

Test 6.4.3.4-2 Sets of characters are allowed. 

Test 6.4.3.4-4 Set bounds are 0. .4095 

Tests 6.7.2.3-2. 6.7.2.3^3 Boolean expressions are fully evaluated. 

Tests 6.S.2.2-1, 6.8.2.2-2 Variables are selected then evaluated. 

Test 6.10-2 A REWRITE on the standard output file is allowed. 

Test 6.11-1 Alternate comment delimiters are implemented,, 

Tests 6. 11-2* 6.11-3 Equivalent symbols are not implemented. 



Detail 5 of Tests Incorrectly died: 



Test 6.6.6.1-1 Functions are not allowed to be passed as parameters. 

Test 6.6.6,2-11 resulted in a floating point runtime error. 

Test 6.^.4-5 executed in an endless loop. Output file from 
*he WRITEUN statement contained lABC. 

Test 6.^.4-il WRITELN does not allow Poo lean variables. 



Quality Tests: 



Total Number of Quality Tests: 23 

Number of Tests Incorrectly Handled: 7 (3 reasons) 



Details of Quality Tests: 



Tests 5.2.2-1* 6.1.3-3 Eight (8) character identifier significance. 

Test 6.1.8-4 Unclosed comments are not detected. 

Test 6.2.1-8 Fifty<50) Types were accepted. 

Test 6.2.1-9 Fiftv<50) LABELS were accepted. 

Test 6.4.3.2-4 Gave the compile-time message: 
•'Array is too large". 

Test 6.4.3.3-? Exact correlation between variant record fields. 

Test 6.5.1-2 Long declaration lists are allowed. 

Test 6.6.1-7 Seven<7) procedure/function declarations could 
be nested. Note: the compiler manual states that the 
max nesting level is 12. 

Test 6.7.2.2-4 -BIV by negative operands is implemented and 

consistent. BIV into negative operands is inconsistent. 
Quotient-TRUNC<A/B> for negative operands. MOB<A*B> 
lies in <0,B-1). 

Test 6.8.3.5-2 Impossible CASE paths are not detected. 

Test 6.8.3.9-18 Range checking is done on a CASE statement 
after a FOR loop. 

Test 6.8.3.9-20 FOR statements can be nested to 
> fifteen<15) Levels. 

Test 6.8.3.10-7 El even (11) WITH statements can be nested. 

The compiler manual states that the maximum next ins of 
procedures* witn— do* and record type descriptions is twelve(12). 

Test 6.9.4-10 Output is flushed at end-of-Job. 

Test 6.9.4-14 Recursive I/O is allowed. 

Details of Tests Incorrectly standi eds 



Test 6.4.3.4-5 'process time' is not implemented. 



Tests 6.6.6.2-6, 6.6.6.2-7, £.6 
Failed to compile because 
the range +-32767, 'e' is 
for '£^ in real constants 
larse for the compiler to 
it had hit the end of the 
Mote? the compiler manual 
any procedure or function 



6.2-8, 6.6.6.2-9, 6.6.6.2-10 
integer constants must be in 
not accepted as a substitute 

the program blocks where too 
handle, and the compiler thought 
program when it hadn't. 
states that the object code for 
cannot be larger than 2000 bytes. 



Test 6.8.3.5-8 failed to compile after 121 case statement parts 
because the program block was too large. 



Extension Tests s 

Total # of Extension Tests* 1 
Details of Extension Tests s 



Test 6.8.3.S-14 The extension 'OTHERWISE' is not implemented. 
'ELSE' is accepted to handle the same function. 



Notes about the AlphaPASCAL compiler: 



Previous versions of ^AlphaPASCAL used the UCSD Pascal 
programming system. The new AlphaPASCAL system consists 
of a compiler, linker, external library and a run-time 
package. Text editors a;re used to create source programs. 
The compiler generates intermediate files for use by the 
1 inker ^ The linker takes the intermediate files and an 
external library to create a runnable P-code file. 

External Procedures end functions can be separately compiled 
and Placed in an external library for future linking with 
programs. Machine language subroutines can also be written 
and linked into programs. 

AlphaPASCAL run-time uses a virtual memory paging system so 
there is no slae limit on P-code files. The run-time Package 
provides for operator interrupts of program execution al lowing 
program termination* program resumption and a backtrace of all 
procedures and functions currently active. 



Comments on the validation Suites 



1) Some tests are too large (oriented towards mainframes?). 
SORT, ARCTAN, LN, etc. tests (6.6.6.2-6,7,8,9, 10) should 
be broken up. These cause problems with a compiler on 
smaller machines. Correctness of function should use 
tests acceptable to large and small computers. 

2) How about a new validation section called "performance"? 
Would showing the performance of compilation and execution 
(could be part of the QUALITY tests). Could check to 

see what (if any) optimization is done. 



3) What good is the EXTENSION test and extension tests as part 
of DEVIANCE? Most deviations are extensions. Isn't the 
object of the suite to test language standards? All 
production compilers are going to have extensions. Some 
extensions will be "standard" in the industry while others 
will be strictly custom. 



IMPLEMENTATION NOTES ONE PURPOSE COUPON 

0. DATE 

1. IMPLEMENTOR/MAINTAINER/DISTRIBUTOR (* Give a person, address and phone number. V 



2. MAC H I N E /S YSTE M CO IM F I G U RATI ON f* Any known limits on the configuration or support software required, e.g. 

operating system. *) 



3. DISTRIBUTION (* Who to ask, how it comes, in what options, and at what price. *) 



4. DOCUMENTATION f* What is available and where. *)* 



5. MAINTENANCE (* Is it unmaintained, fully maintained, etc? *) 



6. STANDARD f* How does it measure up to standard Pascal? Is it a subset? Extended? How. *) 



7. MEASUREMENTS (* Of its speed or space. V 



8. RELI ABI LITY (* Any information about field use or sites installed. *) 



9. DEVELOPMENT METHOD (* How was it developed and what was it written in? *) 



1 0. LIBRARY SUPPORT (* Any other support for compiler in the form of linkages to other languages, source libraries, etc. *) 



(FOLD HERE) 



PLACE 

POSTAGE 

HERE 



Bob Dietrich 
M-S. 92-134 
Tektronix, Inc. 
P.O. Box 500 
Beaverton, Oregon 97077 
USX 



(POLO HIRE} 



NOTE: Paged! News publishes alt the Checklists it 
gets, (mplementors should send us their checklists 
for their products so the thousands of committed 
Pascalers can judge them for their merit, Otherwise 
we must rely on rumors. 



Pimm feel free to use additional sheets of paper. 



IMPLEMENTATION NOTES ONE PURPOSE COUPON 



